melf (empty) → 1.0.0
raw patch · 26 files changed
+4220/−0 lines, 26 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, containers, directory, exceptions, filepath, melf, mtl, optparse-applicative, prettyprinter, singletons, tasty, tasty-golden, tasty-hunit, template-haskell, unix
Files
- ChangeLog.md +4/−0
- LICENSE +29/−0
- README.md +29/−0
- Setup.hs +2/−0
- app/hObjDump.hs +45/−0
- app/hObjLayout.hs +20/−0
- examples/AsmAarch64.hs +258/−0
- examples/Examples.hs +68/−0
- examples/ForwardLabel.hs +45/−0
- examples/HelloWorld.hs +34/−0
- examples/MkExe.hs +45/−0
- examples/MkObj.hs +89/−0
- melf.cabal +155/−0
- src/Control/Exception/ChainedException.hs +129/−0
- src/Data/BList.hs +30/−0
- src/Data/Elf.hs +33/−0
- src/Data/Elf/Constants.hs +18/−0
- src/Data/Elf/Constants/Data.hs +433/−0
- src/Data/Elf/Constants/TH.hs +161/−0
- src/Data/Elf/Headers.hs +698/−0
- src/Data/Elf/PrettyPrint.hs +498/−0
- src/Data/Endian.hs +48/−0
- src/Data/Internal/Elf.hs +986/−0
- src/Data/Interval.hs +35/−0
- tests/Golden.hs +261/−0
- tests/exceptions/Exceptions.hs +67/−0
+ ChangeLog.md view
@@ -0,0 +1,4 @@+1.0.0+=====++Initial release
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2020-2021, Aleksey Makarov+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,29 @@+# melf++> A [Haskell](https://www.haskell.org/) library to parse/serialize+> Executable and Linkable Format ([ELF](https://en.wikipedia.org/wiki/Executable_and_Linkable_Format))++## Related work++- [elf](https://github.com/wangbj/elf) - does not write ELF, only parses it+- [data-elf](https://github.com/mvv/data-elf) - parses just headers/tables; depends on a library that fails to build with modern GHCs++## History++For the early history look at the branch "[amakarov](https://github.com/aleksey-makarov/elf/tree/amakarov)" of+the my copy of the [elf](https://github.com/aleksey-makarov/elf) repo.++## How to build++- [Install](https://nixos.org/manual/nix/stable/#chap-installation) Nix+- `nix-shell`+- `cabal new-configure; cabal new-build`++## Tests++Test data is committed with [git-lfs](https://git-lfs.github.com/).+To run tests, issue this command in `nix-shell`: `cabal new-test --test-show-details=direct`++## License++BSD 3-Clause License (c) Aleksey Makarov
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/hObjDump.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ApplicativeDo #-}++import qualified Data.ByteString as BS+import Data.ByteString.Lazy as BSL+import Prettyprinter+import Prettyprinter.Util+import Options.Applicative++import Data.Elf+import Data.Elf.PrettyPrint++data Options = Options+ { optArgs :: [String]+ , optFull :: Bool+ }++opts' :: Parser Options+opts' = do+ optFull <- switch ( short 'f'+ <> long "full"+ <> help "Don't shorten data and symbol tables"+ )+ optArgs <- some $ argument str ( metavar "FILE" )+ pure Options {..}++opts :: ParserInfo Options+opts = info (opts' <**> helper)+ ( fullDesc+ <> progDesc "Dump ELF files FILEs"+ <> header "hobjdump - dump ELF files"+ )++-- FIXME: use instance Binary Elf'+printFile :: Bool -> String -> IO ()+printFile full fileName = do+ bs <- fromStrict <$> BS.readFile fileName+ elf <- parseElf bs+ doc <- printElf_ full elf+ putDocW 80 (doc <> line)++main :: IO ()+main = do+ Options {..} <- execParser opts+ mapM_ (printFile optFull) optArgs
+ app/hObjLayout.hs view
@@ -0,0 +1,20 @@+import qualified Data.ByteString as BS+import Data.ByteString.Lazy as BSL+import Prettyprinter+import Prettyprinter.Util+import System.Environment++import Data.Elf.Headers+import Data.Elf.PrettyPrint++printFile :: String -> IO ()+printFile fileName = do+ bs <- fromStrict <$> BS.readFile fileName+ hdrs <- parseHeaders bs+ doc <- printLayout hdrs bs+ putDocW 80 (doc <> line)++main :: IO ()+main = do+ args <- getArgs+ mapM_ printFile args
+ examples/AsmAarch64.hs view
@@ -0,0 +1,258 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module AsmAarch64+ ( CodeState+ , Register+ , RelativeRef+ , adr+ , b+ , mov+ , ldr+ , svc+ , ascii+ , label+ , exportSymbol+ , assemble+ , x0, x1, x2, x8+ , w0, w1+ ) where++import Prelude as P++import Control.Exception.ChainedException+import Control.Monad.Catch+import Control.Monad.State as MS+import Data.Bits+import Data.ByteString.Builder+import Data.ByteString.Lazy as BSL+import Data.ByteString.Lazy.Char8 as BSLC+import Data.Int+import Data.Kind+import Data.Singletons.TH+import Data.Word++import Data.Elf+import Data.Elf.Constants+import Data.Elf.Headers++$(singletons [d| data RegisterWidth = X | W |])++type Register :: RegisterWidth -> Type+newtype Register c = R Word32++newtype CodeOffset = CodeOffset { getCodeOffset :: Int64 } deriving (Eq, Show, Ord, Num, Enum, Real, Integral, Bits, FiniteBits)+newtype Instruction = Instruction { getInstruction :: Word32 } deriving (Eq, Show, Ord, Num, Enum, Real, Integral, Bits, FiniteBits)++data RelativeRef = CodeRef !CodeOffset+ | PoolRef !CodeOffset++-- Args:+-- Offset of the instruction+-- Offset of the pool+type InstructionGen = CodeOffset -> CodeOffset -> Either String Instruction++data CodeState = CodeState+ { offsetInPool :: CodeOffset+ , poolReversed :: [Builder]+ , codeReversed :: [InstructionGen]+ , symbolsRefersed :: [(String, RelativeRef)]+ }++emit' :: MonadState CodeState m => InstructionGen -> m ()+emit' g = modify f where+ f CodeState {..} = CodeState { codeReversed = g : codeReversed+ , ..+ }++emit :: MonadState CodeState m => Instruction -> m ()+emit i = emit' $ \ _ _ -> Right i++emitPool :: MonadState CodeState m => Word -> ByteString -> m RelativeRef+emitPool a bs = state f where+ f CodeState {..} =+ let+ offsetInPool' = align a offsetInPool+ o = builderRepeatZero $ fromIntegral $ offsetInPool' - offsetInPool+ in+ ( PoolRef offsetInPool'+ , CodeState { offsetInPool = fromIntegral (BSL.length bs) + offsetInPool'+ , poolReversed = lazyByteString bs : o : poolReversed+ , ..+ }+ )++label :: MonadState CodeState m => m RelativeRef+label = gets (CodeRef . (* instructionSize) . fromIntegral . P.length . codeReversed)++x0, x1, x2, x8 :: Register 'X+x0 = R 0+x1 = R 1+x2 = R 2+x8 = R 8++w0, w1 :: Register 'W+w0 = R 0+w1 = R 1++isPower2 :: (Bits i, Num i) => i -> Bool+isPower2 n = n .&. (n - 1) == 0++align :: Word -> CodeOffset -> CodeOffset+align a _ | not (isPower2 a) = error "align is not a power of 2"+align 0 n = n+align a n = (n + a' - 1) .&. complement (a' - 1)+ where a' = fromIntegral a++builderRepeatZero :: Int -> Builder+builderRepeatZero n = mconcat $ P.replicate n (word8 0)++b64 :: forall w . SingI w => Register w -> Word32+b64 _ = case sing @ w of+ SX -> 1+ SW -> 0++-- | C6.2.10 ADR+adr :: MonadState CodeState m => Register 'X -> RelativeRef -> m ()+adr (R n) rr = emit' f where++ offsetToImm :: CodeOffset -> Either String Word32+ offsetToImm (CodeOffset o) =+ if not $ isBitN 19 o+ then Left "offset is too big"+ else+ let+ immlo = o .&. 3+ immhi = (o `shiftR` 2) .&. 0x7ffff+ in+ Right $ fromIntegral $ (immhi `shift` 5) .|. (immlo `shift` 29)++ f :: InstructionGen+ f instrAddr poolOffset = do+ imm <- offsetToImm $ findOffset poolOffset rr - instrAddr+ return $ Instruction $ 0x10000000+ .|. imm+ .|. n++-- | C6.2.26 B+b :: MonadState CodeState m => RelativeRef -> m ()+b rr = emit' f where++ offsetToImm26 :: CodeOffset -> Either String Word32+ offsetToImm26 (CodeOffset o)+ | o .&. 0x3 /= 0 = Left $ "offset is not aligned: " ++ show o+ | not $ isBitN 28 o = Left "offset is too big"+ | otherwise = Right $ fromIntegral $ o `shiftR` 2++ f :: InstructionGen+ f instrAddr poolOffset = do+ imm26 <- offsetToImm26 $ findOffset poolOffset rr - instrAddr+ return $ Instruction $ 0x14000000 .|. imm26++-- | C6.2.187 MOV (wide immediate)+mov :: (MonadState CodeState m, SingI w) => Register w -> Word16 -> m ()+mov r@(R n) imm = emit $ Instruction $ (b64 r `shift` 31)+ .|. 0x52800000+ .|. (fromIntegral imm `shift` 5)+ .|. n++-- | The number can be represented with bitN bits+isBitN ::(Num b, Bits b, Ord b) => Int -> b -> Bool+isBitN bitN w =+ let+ m = complement $ (1 `shift` bitN) - 1+ h = w .&. m+ in if w >= 0 then h == 0 else h == m++findOffset :: CodeOffset -> RelativeRef -> CodeOffset+findOffset _poolOffset (CodeRef codeOffset) = codeOffset+findOffset poolOffset (PoolRef offsetInPool) = poolOffset + offsetInPool++-- | C6.2.132 LDR (literal)+ldr :: (MonadState CodeState m, SingI w) => Register w -> RelativeRef -> m ()+ldr r@(R n) rr = emit' f where++ offsetToImm19 :: CodeOffset -> Either String Word32+ offsetToImm19 (CodeOffset o)+ | o .&. 0x3 /= 0 = Left "offset is not aligned"+ | not $ isBitN 21 o = Left "offset is too big"+ | otherwise = Right $ fromIntegral $ o `shiftR` 2++ f :: InstructionGen+ f instrAddr poolOffset = do+ imm19 <- offsetToImm19 $ findOffset poolOffset rr - instrAddr+ return $ Instruction $ (b64 r `shift` 30)+ .|. 0x18000000+ .|. (imm19 `shift` 5)+ .|. n++-- | C6.2.317 SVC+svc :: MonadState CodeState m => Word16 -> m ()+svc imm = emit $ 0xd4000001 .|. (fromIntegral imm `shift` 5)++ascii :: MonadState CodeState m => String -> m RelativeRef+ascii s = emitPool 1 $ BSLC.pack s++exportSymbol :: MonadState CodeState m => String -> RelativeRef -> m ()+exportSymbol s r = modify f where+ f (CodeState {..}) = CodeState { symbolsRefersed = (s, r) : symbolsRefersed+ , ..+ }++instructionSize :: Num b => b+instructionSize = 4++zeroIndexStringItem :: ElfSymbolXX 'ELFCLASS64+zeroIndexStringItem = ElfSymbolXX "" 0 0 0 0 0++assemble :: MonadCatch m => ElfSectionIndex -> StateT CodeState m () -> m (BSL.ByteString, [ElfSymbolXX 'ELFCLASS64])+assemble textSecN m = do++ CodeState {..} <- execStateT m (CodeState 0 [] [] [])++ -- resolve txt++ let+ poolOffset = instructionSize * fromIntegral (P.length codeReversed)+ poolOffsetAligned = align 8 poolOffset++ f :: (InstructionGen, CodeOffset) -> Either String Instruction+ f (ff, n) = ff n poolOffsetAligned++ code <- $eitherAddContext' $ mapM f $ P.zip (P.reverse codeReversed) (fmap (instructionSize *) [CodeOffset 0 .. ])++ let+ codeBuilder = mconcat $ fmap (word32LE . getInstruction) code+ txt = toLazyByteString $ codeBuilder+ <> builderRepeatZero (fromIntegral $ poolOffsetAligned - poolOffset)+ <> mconcat (P.reverse poolReversed)++ -- resolve symbolTable++ let+ ff :: (String, RelativeRef) -> ElfSymbolXX 'ELFCLASS64+ ff (s, r) =+ let+ steName = s+ steBind = STB_Global+ steType = STT_NoType+ steShNdx = textSecN+ steValue = fromIntegral $ findOffset poolOffset r+ steSize = 0+ in+ ElfSymbolXX{..}++ symbolTable = ff <$> P.reverse symbolsRefersed++ return (txt, zeroIndexStringItem : symbolTable)
+ examples/Examples.hs view
@@ -0,0 +1,68 @@+module Main (main) where++import Control.Monad.Fix+import Control.Monad.Catch+import Data.Bits+import Data.ByteString.Lazy as BSL+import System.FilePath+import System.Posix.Files+import Test.Tasty+import Test.Tasty.Golden+import Test.Tasty.HUnit++import Data.Elf+import Data.Elf.PrettyPrint++import MkObj+import MkExe+import HelloWorld+import ForwardLabel++makeFileExecutable :: String -> IO ()+makeFileExecutable path = do+ m <- fileMode <$> getFileStatus path+ setFileMode path $ m .|. ownerExecuteMode++helloWorldExe :: MonadCatch m => m Elf+helloWorldExe = mkExe helloWorld++forwardLabelExe :: (MonadCatch m, MonadFix m) => m Elf+forwardLabelExe = mkExe forwardLabel++helloWorldObj :: MonadCatch m => m Elf+helloWorldObj = mkObj helloWorld++fixTargetName :: String -> String+fixTargetName = fmap f+ where+ f '.' = '_'+ f x = x++writeElf :: FilePath -> Elf -> IO ()+writeElf path elf = do+ e <- serializeElf elf+ BSL.writeFile path e+ makeFileExecutable path++testElf :: String -> IO Elf -> [ TestTree ]+testElf elfFileName elf =+ [ testCase makeTargetName (elf >>= writeElf f)+ , after AllSucceed makeTargetName $ testGroup checkTargetName+ [ goldenVsFile "dump" (d <.> "golden") d (writeElfDump f d)+ , goldenVsFile "layout" (l <.> "golden") l (writeElfLayout f l)+ ]+ ]+ where+ makeTargetName = "make_" ++ fixTargetName elfFileName+ checkTargetName = "check_" ++ fixTargetName elfFileName+ t = "examples"+ f = t </> elfFileName+ d = t </> elfFileName <.> "dump"+ l = t </> elfFileName <.> "layout"++main :: IO ()+main = defaultMain $ testGroup "examples"+ ( testElf "helloWorldObj.o" helloWorldObj+ ++ testElf "helloWorldExe" helloWorldExe+ ++ testElf "forwardLabelExe" forwardLabelExe+ )
+ examples/ForwardLabel.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RecursiveDo #-}++module ForwardLabel (forwardLabel) where++import Prelude as P++import Control.Monad.Catch+import Control.Monad.Fix+import Control.Monad.State++import AsmAarch64++ok :: String+ok = "ok\n"++bad :: String+bad = "bad\n"++forwardLabel :: (MonadCatch m, MonadFix m) => StateT CodeState m ()+forwardLabel = mdo++ label >>= exportSymbol "_start"++ lOk <- ascii ok+ lBad <- ascii bad++ mov x0 1++ adr x1 lOk+ mov x2 $ fromIntegral $ P.length ok++ b skipBad++ adr x1 lBad+ mov x2 $ fromIntegral $ P.length bad++ skipBad <- label++ mov x8 64+ svc 0++ mov x0 0+ mov x8 93+ svc 0
+ examples/HelloWorld.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DataKinds #-}++module HelloWorld (helloWorld) where++import Prelude as P++import Control.Monad.Catch+import Control.Monad.State+import Data.Word++import AsmAarch64++msg :: String+msg = "Hello World!\n"++sys_exit, sys_write :: Word16+sys_write = 64+sys_exit = 93++helloWorld :: MonadCatch m => StateT CodeState m ()+helloWorld = do++ start <- label+ exportSymbol "_start" start+ mov x0 1+ helloString <- ascii msg+ adr x1 helloString+ mov x2 $ fromIntegral $ P.length msg+ mov x8 sys_write+ svc 0++ mov x0 0+ mov x8 sys_exit+ svc 0
+ examples/MkExe.hs view
@@ -0,0 +1,45 @@+module MkExe (mkExe) where++import Control.Monad.Catch+import Control.Monad.State+import Data.Bits+import Data.Word+import Data.Singletons.Sigma++import Data.Elf+import Data.Elf.Constants+import Data.Elf.Headers++import AsmAarch64++addr :: Word64+addr = 0x400000++mkExe :: MonadCatch m => StateT CodeState m () -> m Elf+mkExe m = do+ (txt, _) <- assemble 1 m+ let+ segment = ElfSegment+ { epType = PT_LOAD+ , epFlags = PF_X .|. PF_R+ , epVirtAddr = addr+ , epPhysAddr = addr+ , epAddMemSize = 0+ , epAlign = 0x10000+ , epData =+ [ ElfHeader+ { ehData = ELFDATA2LSB+ , ehOSABI = ELFOSABI_SYSV+ , ehABIVersion = 0+ , ehType = ET_EXEC+ , ehMachine = EM_AARCH64+ , ehEntry = addr + headerSize ELFCLASS64+ , ehFlags = 0+ }+ , ElfRawData+ { edData = txt+ }+ , ElfSegmentTable+ ]+ }+ return $ SELFCLASS64 :&: ElfList [ segment ]
+ examples/MkObj.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE DataKinds #-}++module MkObj (mkObj) where++import Prelude as P++import Control.Monad.Catch+import Control.Monad.State+import Data.Bits+import Data.Singletons.Sigma++import Data.Elf+import Data.Elf.Constants+import Data.Elf.Headers++import AsmAarch64++textSecN, shstrtabSecN, strtabSecN, symtabSecN :: ElfSectionIndex+textSecN = 1+shstrtabSecN = 2+strtabSecN = 3+symtabSecN = 4++mkObj :: MonadCatch m => StateT CodeState m () -> m Elf+mkObj m = do++ (txt, symbolTable) <- assemble textSecN m+ (symbolTableData, stringTableData) <- serializeSymbolTable ELFDATA2LSB symbolTable++ return $ SELFCLASS64 :&: ElfList+ [ ElfHeader+ { ehData = ELFDATA2LSB+ , ehOSABI = ELFOSABI_SYSV+ , ehABIVersion = 0+ , ehType = ET_REL+ , ehMachine = EM_AARCH64+ , ehEntry = 0+ , ehFlags = 0+ }+ , ElfSection+ { esName = ".text"+ , esType = SHT_PROGBITS+ , esFlags = SHF_EXECINSTR .|. SHF_ALLOC+ , esAddr = 0+ , esAddrAlign = 8+ , esEntSize = 0+ , esN = textSecN+ , esLink = 0+ , esInfo = 0+ , esData = ElfSectionData txt+ }+ , ElfSection+ { esName = ".shstrtab"+ , esType = SHT_STRTAB+ , esFlags = 0+ , esAddr = 0+ , esAddrAlign = 1+ , esEntSize = 0+ , esN = shstrtabSecN+ , esLink = 0+ , esInfo = 0+ , esData = ElfSectionDataStringTable+ }+ , ElfSection+ { esName = ".symtab"+ , esType = SHT_SYMTAB+ , esFlags = 0+ , esAddr = 0+ , esAddrAlign = 8+ , esEntSize = symbolTableEntrySize ELFCLASS64+ , esN = symtabSecN+ , esLink = fromIntegral strtabSecN+ , esInfo = 1+ , esData = ElfSectionData symbolTableData+ }+ , ElfSection+ { esName = ".strtab"+ , esType = SHT_STRTAB+ , esFlags = 0+ , esAddr = 0+ , esAddrAlign = 1+ , esEntSize = 0+ , esN = strtabSecN+ , esLink = 0+ , esInfo = 0+ , esData = ElfSectionData stringTableData+ }+ , ElfSectionTable+ ]
+ melf.cabal view
@@ -0,0 +1,155 @@+cabal-version: 1.18++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name: melf+version: 1.0.0+synopsis: An Elf parser+description: Parser for ELF object format+category: Data+homepage: https://github.com/aleksey-makarov/melf+bug-reports: https://github.com/aleksey-makarov/melf/issues+author: Aleksey Makarov+maintainer: aleksey.makarov@gmail.com+copyright: Aleksey Makarov+license: BSD3+license-file: LICENSE+build-type: Simple+tested-with:+ GHC == 8.10.4+extra-doc-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/aleksey-makarov/melf++library+ exposed-modules:+ Data.Endian+ Data.Elf+ Data.Elf.Constants+ Data.Elf.Headers+ Data.Elf.PrettyPrint+ Control.Exception.ChainedException+ other-modules:+ Data.Elf.Constants.TH+ Data.Elf.Constants.Data+ Data.Internal.Elf+ Data.Interval+ Data.BList+ hs-source-dirs:+ src+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-redundant-constraints+ build-depends:+ base >=4.6 && <5.0+ , binary >=0.8.8 && <0.9+ , bytestring >=0.10.12 && <0.11+ , exceptions >=0.10.4 && <0.11+ , mtl >=2.2.2 && <2.3+ , prettyprinter >=1.7.0 && <1.8+ , singletons >=2.7 && <3+ , template-haskell ==2.16.*+ default-language: Haskell2010++executable hobjdump+ main-is: hObjDump.hs+ other-modules:+ 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+ build-depends:+ base >=4.6 && <5.0+ , binary+ , bytestring+ , melf+ , optparse-applicative >=0.16.1 && <0.17+ , prettyprinter+ default-language: Haskell2010++executable hobjlayout+ main-is: hObjLayout.hs+ other-modules:+ 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+ build-depends:+ base >=4.6 && <5.0+ , binary+ , bytestring+ , exceptions+ , melf+ , prettyprinter+ default-language: Haskell2010++test-suite examples+ type: exitcode-stdio-1.0+ main-is: Examples.hs+ other-modules:+ AsmAarch64+ ForwardLabel+ HelloWorld+ MkExe+ MkObj+ Paths_melf+ hs-source-dirs:+ examples+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-redundant-constraints+ build-depends:+ base >=4.6 && <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++test-suite exceptions+ type: exitcode-stdio-1.0+ main-is: Exceptions.hs+ other-modules:+ Paths_melf+ hs-source-dirs:+ tests/exceptions+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-redundant-constraints+ build-depends:+ base >=4.6 && <5.0+ , exceptions+ , melf+ , tasty+ , tasty-hunit+ default-language: Haskell2010++test-suite golden+ type: exitcode-stdio-1.0+ main-is: Golden.hs+ other-modules:+ Paths_melf+ hs-source-dirs:+ tests+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-redundant-constraints+ build-depends:+ base >=4.6 && <5.0+ , binary+ , bytestring+ , directory >=1.3.6 && <1.4+ , exceptions+ , filepath >=1.4.2.1 && <1.5+ , melf+ , prettyprinter+ , singletons+ , tasty >=1.4.1 && <1.5+ , tasty-golden >=2.3.4 && <2.4+ , tasty-hunit >=0.10.0.3 && <0.11+ default-language: Haskell2010
+ src/Control/Exception/ChainedException.hs view
@@ -0,0 +1,129 @@+-- |+-- Module : Control.Exception.ChainedException+-- Description : Exception that keeps the stack of error locations+-- Copyright : (c) Aleksey Makarov, 2021+-- License : BSD 3-Clause License+-- Maintainer : aleksey.makarov@gmail.com+-- Stability : experimental+-- Portability : portable+-- +-- Exception that keeps the stack of error locations.++-- Look also at these:+-- https://hackage.haskell.org/package/loch-th+-- https://github.com/MaartenFaddegon/Hoed++{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RankNTypes #-}++module Control.Exception.ChainedException+ ( ChainedExceptionNext(..)+ , ChainedException(..)+ , chainedError+ , chainedError'+ , addContext+ , addContext'+ , maybeAddContext+ , maybeAddContext'+ , eitherAddContext'+ ) where++-- https://stackoverflow.com/questions/13379356/finding-the-line-number-of-a-function-in-haskell++import Control.Exception hiding (try, catch)+import Control.Monad.Catch+import Language.Haskell.TH++-- | Structure to organize the stack of exceptions with locations+data ChainedExceptionNext = Null -- ^ exception was initiated by @`chainedError`@+ | Next SomeException -- ^ some context was added to @`SomeException`@ by @`addContext`@+ | NextChained ChainedException -- ^ some context was added to a @`ChainedException`@ by @`addContext`@++-- | Exception that keeps track of error locations+data ChainedException = ChainedException+ { err :: String -- ^ description of the error+ , loc :: Loc -- ^ location+ , stack :: ChainedExceptionNext -- ^ stack of locations+ }++formatLoc :: Loc -> String+formatLoc loc =+ let+ file = loc_filename loc+ (line, _) = loc_start loc+ in concat [file, ":", show line]++instance Show ChainedException where+ show ChainedException{..} = showThis ++ case stack of+ Null -> ""+ NextChained ce -> " // " ++ show ce+ Next e -> " // " ++ show e+ where+ showThis = concat [err, if null err then "" else " ", "(", formatLoc loc, ")" ]++instance Exception ChainedException++withLoc :: Q Exp -> Q Exp+withLoc f = appE f (location >>= liftLoc)++liftLoc :: Loc -> Q Exp+liftLoc Loc {..} = [| Loc loc_filename loc_package loc_module loc_start loc_end |]++--------------------------------------------------------++chainedErrorX :: MonadThrow m => Loc -> String -> m a+chainedErrorX loc s = throwM $ ChainedException s loc Null++-- | @\$chainedError@ results in a function of type+-- \'@chainedError :: MonadThrow m => String -> m a@\'.+-- It throws `ChainedException` with its argument as error description.+chainedError :: Q Exp+chainedError = withLoc [| chainedErrorX |]++-- | @\$chainedError'@ is the same as @$`chainedError` ""@+chainedError' :: Q Exp+chainedError' = withLoc [| (`chainedErrorX` []) |]++addContextX :: MonadCatch m => Loc -> String -> m a -> m a+addContextX loc s m = m `catch` f+ where+ f :: MonadThrow m => SomeException -> m a+ f e = throwM $ ChainedException s loc $ case fromException e of+ Just ce -> NextChained ce+ Nothing -> Next e++-- | @\$addContext@ results in a function of type+-- \'@addContext :: MonadCatch m => String -> m a -> m a@\'.+-- It runs the second argument and adds `ChainedException` with its first argument+-- to the exceptions thrown from that monad.+addContext :: Q Exp+addContext = withLoc [| addContextX |]++-- | @\$addContext'@ is the same as @$addContext ""@+addContext' :: Q Exp+addContext' = withLoc [| (`addContextX` []) |]++maybeAddContextX :: MonadThrow m => Loc -> String -> Maybe a -> m a+maybeAddContextX loc s = maybe (throwM $ ChainedException s loc Null) return++-- | @\$maybeAddContext@ results in a function of type+-- \'@maybeAddContext :: MonadThrow m => String -> Maybe a -> m a@\'.+-- If its second argument is `Nothing`, it throws `ChainedException` with its first argument,+-- else it returns the value of `Just`.+maybeAddContext :: Q Exp+maybeAddContext = withLoc [| maybeAddContextX |]++-- | @\$maybeAddContext'@ is the same as @$maybeAddContext ""@+maybeAddContext' :: Q Exp+maybeAddContext' = withLoc [| (`maybeAddContextX` []) |]++eitherAddContextX :: MonadThrow m => Loc -> Either String a -> m a+eitherAddContextX loc = either (\ s -> throwM $ ChainedException s loc Null) return++-- | @\$eitherAddContext'@ results in a function of type+-- \'@eitherAddContext' :: MonadThrow m => Either String a -> m a@\'.+-- If its argument is @`Left` e@, it throws `ChainedException` with @e@ as error description,+-- else it returns the value of `Right`.+eitherAddContext' :: Q Exp+eitherAddContext' = withLoc [| eitherAddContextX |]
+ src/Data/BList.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveFunctor #-}++module Data.BList (BList(..)) where++import Data.Binary.Get+import Data.Binary++import Data.Endian++newtype BList a = BList { fromBList :: [a] } deriving Functor++instance Binary a => Binary (BList a) where+ put (BList (a:as)) = put a >> put (BList as)+ put (BList []) = return ()+ get = do+ e <- isEmpty+ if e then return $ BList [] else do+ a <- get+ (BList as) <- get+ return $ BList $ a : as++instance Binary (Be a) => Binary (Be (BList a)) where+ put (Be (BList l)) = put $ BList $ fmap Be l+ get = Be . fmap fromBe <$> get++instance Binary (Le a) => Binary (Le (BList a)) where+ put (Le (BList l)) = put $ BList $ fmap Le l+ get = Le . fmap fromLe <$> get
+ src/Data/Elf.hs view
@@ -0,0 +1,33 @@+-- |+-- Module : Data.ELF+-- Description : Parse/serialize ELF files into structured data+-- Copyright : (c) Aleksey Makarov, 2021+-- License : BSD 3-Clause License+-- Maintainer : aleksey.makarov@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- Parse/serialize ELF files into structured data++module Data.Elf (+ -- * Elf+ ElfList (..)+ , Elf+ , ElfSectionData (..)+ , ElfXX (..)+ , parseElf+ , serializeElf++ -- * Misc+ , getSectionData+ , getString+ , elfFindSection+ , elfFindHeader++ -- * Symbol table+ , ElfSymbolXX(..)+ , parseSymbolTable+ , serializeSymbolTable+ ) where++import Data.Internal.Elf
+ src/Data/Elf/Constants.hs view
@@ -0,0 +1,18 @@+-- |+-- Module : Data.ELF.Constants+-- Description : Definitions of constants used in ELF files+-- Copyright : (c) Aleksey Makarov, 2021+-- License : BSD 3-Clause License+-- Maintainer : aleksey.makarov@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- Definitions of constants used in ELF files++-- https://stackoverflow.com/questions/10672981/export-template-haskell-generated-definitions++module Data.Elf.Constants (+ -- $docs+ module Data.Elf.Constants.Data+ ) where+import Data.Elf.Constants.Data
+ src/Data/Elf/Constants/Data.hs view
@@ -0,0 +1,433 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Data.Elf.Constants.Data where++import Data.Binary+import Data.Binary.Put+import Data.Binary.Get+import Data.Bits++import Data.Elf.Constants.TH+import Data.Endian++{- $docs++Constants defined here are declared using Template Haskell so there are no docs.+See the sources or the documents describing ELF file format.++Data types, patterns and instances are generated by @mkDeclarations@ TH macros.+Below is an example of how it works. The code++@+$(mkDeclarations BaseWord16 \"TypeName\" \"ValuePrefix\" \"DefaultConstructorName\"+ [ (\"_A\", 0)+ , (\"_B\", 1)+ ])+@++produces this:++@+ newtype TypeName = TypeName Word16 deriving (Eq, Ord, Enum, Num, Real, Integral, Bits, FiniteBits)++ instance Show TypeName where+ show (TypeName 0) = (\"ValuePrefix\" ++ "_A")+ show (TypeName 1) = (\"ValuePrefix\" ++ "_B")+ show (TypeName n_a5QI) = (\"DefaultConstructorName\" ++ (\" \" ++ show n_a5QI))++ pattern ValuePrefix_A :: TypeName+ pattern ValuePrefix_A = TypeName 0++ pattern ValuePrefix_B :: TypeName+ pattern ValuePrefix_B = TypeName 1++ pattern DefaultConstructorName :: Word16 -> TypeName+ pattern DefaultConstructorName n_a5QJ = TypeName n_a5QJ++ instance Binary (Le TypeName) where+ get = (Le \<$\> (TypeName \<$\> getWord16le))+ put (Le (TypeName n_a5QK)) = putWord16le n_a5QK++ instance Binary (Be TypeName) where+ get = (Be \<$\> (TypeName \<$\> getWord16be))+ put (Be (TypeName n_a5QL)) = putWord16be n_a5QL+@+-}++-- | Operating system and ABI for which the object is prepared+$(mkDeclarations BaseWord8 "ElfOSABI" "ELFOSABI" "ELFOSABI_EXT"+ [ ("_SYSV", 0) -- No extensions or unspecified+ , ("_HPUX", 1) -- Hewlett-Packard HP-UX+ , ("_NETBSD", 2) -- NetBSD+ , ("_LINUX", 3) -- Linux+ , ("_SOLARIS", 6) -- Sun Solaris+ , ("_AIX", 7) -- AIX+ , ("_IRIX", 8) -- IRIX+ , ("_FREEBSD", 9) -- FreeBSD+ , ("_TRU64", 10) -- Compaq TRU64 UNIX+ , ("_MODESTO", 11) -- Novell Modesto+ , ("_OPENBSD", 12) -- Open BSD+ , ("_OPENVMS", 13) -- Open VMS+ , ("_NSK", 14) -- Hewlett-Packard Non-Stop Kernel+ , ("_AROS", 15) -- Amiga Research OS+ , ("_ARM", 97) -- ARM+ , ("_STANDALONE", 255) -- Standalone (embedded) application+ ])++-- | Object file type+$(mkDeclarations BaseWord16 "ElfType" "ET" "ET_EXT"+ [ ("_NONE", 0) -- Unspecified type+ , ("_REL", 1) -- Relocatable object file+ , ("_EXEC", 2) -- Executable object file+ , ("_DYN", 3) -- Shared object file+ , ("_CORE", 4) -- Core dump object file+ ])++-- | Target architecture+$(mkDeclarations BaseWord16 "ElfMachine" "EM" "EM_EXT"+ [ ("_NONE", 0) -- No machine+ , ("_M32", 1) -- AT&T WE 32100+ , ("_SPARC", 2) -- SPARC+ , ("_386", 3) -- Intel 80386+ , ("_68K", 4) -- Motorola 68000+ , ("_88K", 5) -- Motorola 88000+ , ("_486", 6) -- Intel i486 (DO NOT USE THIS ONE)+ , ("_860", 7) -- Intel 80860+ , ("_MIPS", 8) -- MIPS I Architecture+ , ("_S370", 9) -- IBM System/370 Processor+ , ("_MIPS_RS3_LE", 10) -- MIPS RS3000 Little-endian+ , ("_SPARC64", 11) -- SPARC 64-bit+ , ("_PARISC", 15) -- Hewlett-Packard PA-RISC+ , ("_VPP500", 17) -- Fujitsu VPP500+ , ("_SPARC32PLUS", 18) -- Enhanced instruction set SPARC+ , ("_960", 19) -- Intel 80960+ , ("_PPC", 20) -- PowerPC+ , ("_PPC64", 21) -- 64-bit PowerPC+ , ("_S390", 22) -- IBM System/390 Processor+ , ("_SPU", 23) -- Cell SPU+ , ("_V800", 36) -- NEC V800+ , ("_FR20", 37) -- Fujitsu FR20+ , ("_RH32", 38) -- TRW RH-32+ , ("_RCE", 39) -- Motorola RCE+ , ("_ARM", 40) -- Advanced RISC Machines ARM+ , ("_ALPHA", 41) -- Digital Alpha+ , ("_SH", 42) -- Hitachi SH+ , ("_SPARCV9", 43) -- SPARC Version 9+ , ("_TRICORE", 44) -- Siemens TriCore embedded processor+ , ("_ARC", 45) -- Argonaut RISC Core, Argonaut Technologies Inc.+ , ("_H8_300", 46) -- Hitachi H8/300+ , ("_H8_300H", 47) -- Hitachi H8/300H+ , ("_H8S", 48) -- Hitachi H8S+ , ("_H8_500", 49) -- Hitachi H8/500+ , ("_IA_64", 50) -- Intel IA-64 processor architecture+ , ("_MIPS_X", 51) -- Stanford MIPS-X+ , ("_COLDFIRE", 52) -- Motorola ColdFire+ , ("_68HC12", 53) -- Motorola M68HC12+ , ("_MMA", 54) -- Fujitsu MMA Multimedia Accelerator+ , ("_PCP", 55) -- Siemens PCP+ , ("_NCPU", 56) -- Sony nCPU embedded RISC processor+ , ("_NDR1", 57) -- Denso NDR1 microprocessor+ , ("_STARCORE", 58) -- Motorola Star*Core processor+ , ("_ME16", 59) -- Toyota ME16 processor+ , ("_ST100", 60) -- STMicroelectronics ST100 processor+ , ("_TINYJ", 61) -- Advanced Logic Corp. TinyJ embedded processor family+ , ("_X86_64", 62) -- AMD x86-64 architecture+ , ("_PDSP", 63) -- Sony DSP Processor+ , ("_FX66", 66) -- Siemens FX66 microcontroller+ , ("_ST9PLUS", 67) -- STMicroelectronics ST9+ 8/16 bit microcontroller+ , ("_ST7", 68) -- STMicroelectronics ST7 8-bit microcontroller+ , ("_68HC16", 69) -- Motorola MC68HC16 Microcontroller+ , ("_68HC11", 70) -- Motorola MC68HC11 Microcontroller+ , ("_68HC08", 71) -- Motorola MC68HC08 Microcontroller+ , ("_68HC05", 72) -- Motorola MC68HC05 Microcontroller+ , ("_SVX", 73) -- Silicon Graphics SVx+ , ("_ST19", 74) -- STMicroelectronics ST19 8-bit microcontroller+ , ("_VAX", 75) -- Digital VAX+ , ("_CRIS", 76) -- Axis Communications 32-bit embedded processor+ , ("_JAVELIN", 77) -- Infineon Technologies 32-bit embedded processor+ , ("_FIREPATH", 78) -- Element 14 64-bit DSP Processor+ , ("_ZSP", 79) -- LSI Logic 16-bit DSP Processor+ , ("_MMIX", 80) -- Donald Knuth's educational 64-bit processor+ , ("_HUANY", 81) -- Harvard University machine-independent object files+ , ("_PRISM", 82) -- SiTera Prism+ , ("_AVR", 83) -- Atmel AVR 8-bit microcontroller+ , ("_FR30", 84) -- Fujitsu FR30+ , ("_D10V", 85) -- Mitsubishi D10V+ , ("_D30V", 86) -- Mitsubishi D30V+ , ("_V850", 87) -- NEC v850+ , ("_M32R", 88) -- Mitsubishi M32R+ , ("_MN10300", 89) -- Matsushita MN10300+ , ("_MN10200", 90) -- Matsushita MN10200+ , ("_PJ", 91) -- picoJava+ , ("_OPENRISC", 92) -- OpenRISC 32-bit embedded processor+ , ("_ARC_A5", 93) -- ARC Cores Tangent-A5+ , ("_XTENSA", 94) -- Tensilica Xtensa Architecture+ , ("_VIDEOCORE", 95) -- Alphamosaic VideoCore processor+ , ("_TMM_GPP", 96) -- Thompson Multimedia General Purpose Processor+ , ("_NS32K", 97) -- National Semiconductor 32000 series+ , ("_TPC", 98) -- Tenor Network TPC processor+ , ("_SNP1K", 99) -- Trebia SNP 1000 processor+ , ("_ST200", 100) -- STMicroelectronics (www.st.com) ST200 microcontroller+ , ("_IP2K", 101) -- Ubicom IP2xxx microcontroller family+ , ("_MAX", 102) -- MAX Processor+ , ("_CR", 103) -- National Semiconductor CompactRISC microprocessor+ , ("_F2MC16", 104) -- Fujitsu F2MC16+ , ("_MSP430", 105) -- Texas Instruments embedded microcontroller msp430+ , ("_BLACKFIN", 106) -- Analog Devices Blackfin (DSP) processor+ , ("_SE_C33", 107) -- S1C33 Family of Seiko Epson processors+ , ("_SEP", 108) -- Sharp embedded microprocessor+ , ("_ARCA", 109) -- Arca RISC Microprocessor+ , ("_UNICORE", 110) -- Microprocessor series from PKU-Unity Ltd. and MPRC of Peking University+ , ("_AARCH64", 183) -- ELF for the Arm 64-bit Architecture (AArch64)+ ])++-- | Section type+$(mkDeclarations BaseWord32 "ElfSectionType" "SHT" "SHT_EXT"+ [ ("_NULL", 0) -- Identifies an empty section header.+ , ("_PROGBITS", 1) -- Contains information defined by the program+ , ("_SYMTAB", 2) -- Contains a linker symbol table+ , ("_STRTAB", 3) -- Contains a string table+ , ("_RELA", 4) -- Contains "Rela" type relocation entries+ , ("_HASH", 5) -- Contains a symbol hash table+ , ("_DYNAMIC", 6) -- Contains dynamic linking tables+ , ("_NOTE", 7) -- Contains note information+ , ("_NOBITS", 8) -- Contains uninitialized space; does not occupy any space in the file+ , ("_REL", 9) -- Contains "Rel" type relocation entries+ , ("_SHLIB", 10) -- Reserved+ , ("_DYNSYM", 11) -- Contains a dynamic loader symbol table+ ])++-- | Segment type+$(mkDeclarations BaseWord32 "ElfSegmentType" "PT" "PT_EXT"+ [ ("_NULL", 0) -- Unused entry+ , ("_LOAD", 1) -- Loadable segment+ , ("_DYNAMIC", 2) -- Dynamic linking tables+ , ("_INTERP", 3) -- Program interpreter path name+ , ("_NOTE", 4) -- Note section+ , ("_SHLIB", 5) -- Reserved+ , ("_PHDR", 6) -- Program header table+ ])++-- | Attributes of the section+$(mkDeclarations BaseWord64 "ElfSectionFlag" "SHF" "SHF_EXT"+ [ ("_WRITE", 1 `shiftL` 0) -- Section contains writable data+ , ("_ALLOC", 1 `shiftL` 1) -- Section is allocated in memory image of program+ , ("_EXECINSTR", 1 `shiftL` 2) -- Section contains executable instructions+ ])++-- | Attributes of the segment+$(mkDeclarations BaseWord32 "ElfSegmentFlag" "PF" "PF_EXT"+ [ ("_X", 1 `shiftL` 0) -- Execute permission+ , ("_W", 1 `shiftL` 1) -- Write permission+ , ("_R", 1 `shiftL` 2) -- Read permission+ ])++-- | Symbol type+$(mkDeclarations BaseWord8 "ElfSymbolType" "STT" "STT_EXT"+ [ ("_NoType", 0)+ , ("_Object", 1)+ , ("_Func", 2)+ , ("_Section", 3)+ , ("_File", 4)+ , ("_Common", 5)+ , ("_TLS", 6)+ , ("_LoOS", 10)+ , ("_HiOS", 12)+ , ("_LoProc", 13)+ , ("_HiProc", 15)+ ])++-- | Symbol binding+$(mkDeclarations BaseWord8 "ElfSymbolBinding" "STB" "STB_EXT"+ [ ("_Local", 0)+ , ("_Global", 1)+ , ("_Weak", 2)+ , ("_LoOS", 10)+ , ("_HiOS", 12)+ , ("_LoProc", 13)+ , ("_HiProc", 15)+ ])++-- | Section index+$(mkDeclarations BaseWord16 "ElfSectionIndex" "SHN" "SHN_EXT"+ [ ("_Undef", 0)+ , ("_LoProc", 0xFF00)+ , ("_HiProc", 0xFF1F)+ , ("_LoOS", 0xFF20)+ , ("_HiOS", 0xFF3F)+ , ("_Abs", 0xFFF1)+ , ("_Common", 0xFFF2)+ ])++-- | AARCH64 relocation type+$(mkDeclarations BaseWord32 "ElfRelocationType_AARCH64" "R_AARCH64" "R_AARCH64_EXT"++ -- Null relocation codes++ [ ("_NONE", 0 ) -- None+ , ("_NONE_", 256) -- None++ -- Data relocations++ , ("_ABS64", 257) -- S + A | No overflow check+ , ("_ABS32", 258) -- S + A | Check that -2^31 <= X < 2^32+ , ("_ABS16", 259) -- S + A | Check that -2^15 <= X < 2^16+ , ("_PREL64", 260) -- S + A - P | No overflow check+ , ("_PREL32", 261) -- S + A - P | Check that -2^31 <= X < 2^32+ , ("_PREL16", 262) -- S + A - P | Check that -2^15 <= X < 2^16+ , ("_PLT32", 314) -- S + A - P | Check that -2^31 <= X < 2^31 see call and jump relocations++ -- Group relocations to create a 16-, 32-, 48-, or 64-bit unsigned data value or address inline++ , ("_MOVW_UABS_G0", 263) -- S + A | Set a MOV[KZ] immediate field to bits [15: 0] of X; check that 0 <= X < 2^16+ , ("_MOVW_UABS_G0_NC", 264) -- S + A | Set a MOV[KZ] immediate field to bits [15: 0] of X. No overflow check+ , ("_MOVW_UABS_G1", 265) -- S + A | Set a MOV[KZ] immediate field to bits [31:16] of X; check that 0 <= X < 2^32+ , ("_MOVW_UABS_G1_NC", 266) -- S + A | Set a MOV[KZ] immediate field to bits [31:16] of X. No overflow check+ , ("_MOVW_UABS_G2", 267) -- S + A | Set a MOV[KZ] immediate field to bits [47:32] of X; check that 0 <= X < 2^48+ , ("_MOVW_UABS_G2_NC", 268) -- S + A | Set a MOV[KZ] immediate field to bits [47:32] of X. No overflow check+ , ("_MOVW_UABS_G3", 269) -- S + A | Set a MOV[KZ] immediate field to bits [63:48] of X (no overflow check needed)++ -- Group relocations to create a 16, 32, 48, or 64 bit signed data or offset value inline++ , ("_MOVW_SABS_G0", 270) -- S + A | Set a MOV[NZ] immediate field using bits [15: 0] of X; check -2^16 <= X < 2^16+ , ("_MOVW_SABS_G1", 271) -- S + A | Set a MOV[NZ] immediate field using bits [31:16] of X; check -2^32 <= X < 2^32+ , ("_MOVW_SABS_G2", 272) -- S + A | Set a MOV[NZ] immediate field using bits [47:32] of X; check -2^48 <= X < 2^48++ -- Relocations to generate 19, 21 and 33 bit PC-relative addresses++ , ("_LD_PREL_LO19", 273) -- S + A - P | Set a load-literal immediate value to bits [20:2] of X; check that -2^20 <= X < 2^20+ , ("_ADR_PREL_LO21", 274) -- S + A - P | Set an ADR immediate value to bits [20:0] of X; check that -2^20 <= X < 2^20+ , ("_ADR_PREL_PG_HI21", 275) -- Page(S + A) - Page(P) | Set an ADRP immediate value to bits [32:12] of the X; check that -2^32 <= X < 2^32+ , ("_ADR_PREL_PG_HI21_NC", 276) -- Page(S + A) - Page(P) | Set an ADRP immediate value to bits [32:12] of the X. No overflow check+ , ("_ADD_ABS_LO12_NC", 277) -- S + A | Set an ADD immediate value to bits [11:0] of X. No overflow check. Used with relocations ADR_PREL_PG_HI21 and ADR_PREL_PG_HI21_NC+ , ("_LDST8_ABS_LO12_NC", 278) -- S + A | Set an LD/ST immediate value to bits [11:0] of X. No overflow check. Used with relocations ADR_PREL_PG_HI21 and ADR_PREL_PG_HI21_NC+ , ("_LDST16_ABS_LO12_NC", 284) -- S + A | Set an LD/ST immediate value to bits [11:1] of X. No overflow check+ , ("_LDST32_ABS_LO12_NC", 285) -- S + A | Set the LD/ST immediate value to bits [11:2] of X. No overflow check+ , ("_LDST64_ABS_LO12_NC", 286) -- S + A | Set the LD/ST immediate value to bits [11:3] of X. No overflow check+ , ("_LDST128_ABS_LO12_NC", 299) -- S + A | Set the LD/ST immediate value to bits [11:4] of X. No overflow check++ -- Relocations for control-flow instructions - all offsets are a multiple of 4++ , ("_TSTBR14", 279) -- S + A - P | Set the immediate field of a TBZ/TBNZ instruction to bits [15:2] of X; check -2^15 <= X < 2^15+ , ("_CONDBR19", 280) -- S + A - P | Set the immediate field of a conditional branch instruction to bits [20:2] of X; check -2^20 <= X< 2^20+ , ("_JUMP26", 282) -- S + A - P | Set a B immediate field to bits [27:2] of X; check that -2^27 <= X < 2^27+ , ("_CALL26", 283) -- S + A - P | Set a CALL immediate field to bits [27:2] of X; check that -2^27 <= X < 2^27++ -- Group relocations to create a 16, 32, 48, or 64 bit PC-relative offset inline++ , ("_MOVW_PREL_G0", 287) -- S + A - P | Set a MOV[NZ]immediate field to bits [15:0] of X+ , ("_MOVW_PREL_G0_NC", 288) -- S + A - P | Set a MOVK immediate field to bits [15:0] of X. No overflow check+ , ("_MOVW_PREL_G1", 289) -- S + A - P | Set a MOV[NZ]immediate field to bits [31:16] of X+ , ("_MOVW_PREL_G1_NC", 290) -- S + A - P | Set a MOVK immediate field to bits [31:16] of X. No overflow check+ , ("_MOVW_PREL_G2", 291) -- S + A - P | Set a MOV[NZ]immediate value to bits [47:32] of X+ , ("_MOVW_PREL_G2_NC", 292) -- S + A - P | Set a MOVK immediate field to bits [47:32] of X. No overflow check+ , ("_MOVW_PREL_G3", 293) -- S + A - P | Set a MOV[NZ]immediate value to bits [63:48] of X++ -- Group relocations to create a 16, 32, 48, or 64 bit GOT-relative offsets inline++ , ("_MOVW_GOTOFF_G0", 300) -- G(GDAT(S + A)) - GOT | Set a MOV[NZ] immediate field to bits [15:0] of X+ , ("_MOVW_GOTOFF_G0_NC", 301) -- G(GDAT(S + A)) - GOT | Set a MOVK immediate field to bits [15:0] of X. No overflow check+ , ("_MOVW_GOTOFF_G1", 302) -- G(GDAT(S + A)) - GOT | Set a MOV[NZ] immediate value to bits [31:16] of X+ , ("_MOVW_GOTOFF_G1_NC", 303) -- G(GDAT(S + A)) - GOT | Set a MOVK immediate value to bits [31:16] of X. No overflow check+ , ("_MOVW_GOTOFF_G2", 304) -- G(GDAT(S + A)) - GOT | Set a MOV[NZ] immediate value to bits [47:32] of X+ , ("_MOVW_GOTOFF_G2_NC", 305) -- G(GDAT(S + A)) - GOT | Set a MOVK immediate value to bits [47:32] of X. No overflow check+ , ("_MOVW_GOTOFF_G3", 306) -- G(GDAT(S + A)) - GOT | Set a MOV[NZ] immediate value to bits [63:48] of X++ -- GOT-relative data relocations++ , ("_GOTREL64", 307) -- S + A - GOT | Set the data to a 64-bit offset relative to the GOT.+ , ("_GOTREL32", 308) -- S + A - GOT | Set the data to a 32-bit offset relative to GOT, treated as signed; check that -2^31 <= X < 2^31++ -- GOT-relative instruction relocations++ , ("_GOT_LD_PREL19", 309) -- G(GDAT(S + A))- P | Set a load-literal immediate field to bits [20:2] of X; check –2^20 <= X < 2^20+ , ("_LD64_GOTOFF_LO15", 310) -- G(GDAT(S + A))- GOT | Set a LD/ST immediate field to bits [14:3] of X; check that 0 <= X < 2^15 , X&7 = 0+ , ("_ADR_GOT_PAGE", 311) -- Page(G(GDAT(S + A)))- Page(P) | Set the immediate value of an ADRP to bits [32:12] of X; check that –2^32 <= X < 2^32+ , ("_LD64_GOT_LO12_NC", 312) -- G(GDAT(S + A)) | Set the LD/ST immediate field to bits [11:3] of X. No overflow check; check that X&7 = 0+ , ("_LD64_GOTPAGE_LO15", 313) -- G(GDAT(S + A))- Page(GOT) | Set the LD/ST immediate field to bits [14:3] of X; check that 0 <= X < 2^15, X&7 = 0++ -- Local Dynamic TLS relocations++ , ("_TLSLD_ADR_PREL21", 517) -- G(GLDM(S))) - P | Set an ADR immediate field to bits [20:0] of X; check –2^20 <= X < 2^20+ , ("_TLSLD_ADR_PAGE21", 518) -- Page(G(GLDM(S))) - Page(P) | Set an ADRP immediate field to bits [32:12] of X; check –2^32 <= X < 2^32+ , ("_TLSLD_ADD_LO12_NC", 519) -- G(GLDM(S)) | Set an ADD immediate field to bits [11:0] of X. No overflow check+ , ("_TLSLD_MOVW_G1", 520) -- G(GLDM(S)) - GOT | Set a MOV[NZ] immediate field to bits [31:16] of X+ , ("_TLSLD_MOVW_G0_NC", 521) -- G(GLDM(S)) - GOT | Set a MOVK immediate field to bits [15:0] of X. No overflow check+ , ("_TLSLD_LD_PREL19", 522) -- G(GLDM(S)) - P | Set a load-literal immediate field to bits [20:2] of X; check –2^20 <= X < 2^20+ , ("_TLSLD_MOVW_DTPREL_G2", 523) -- DTPREL(S+A) | Set a MOV[NZ] immediate field to bits [47:32] of X+ , ("_TLSLD_MOVW_DTPREL_G1", 524) -- DTPREL(S+A) | Set a MOV[NZ] immediate field to bits [31:16] of X+ , ("_TLSLD_MOVW_DTPREL_G1_NC", 525) -- DTPREL(S+A) | Set a MOVK immediate field to bits [31:16] of X. No overflow check+ , ("_TLSLD_MOVW_DTPREL_G0", 526) -- DTPREL(S+A) | Set a MOV[NZ] immediate field to bits [15:0] of X+ , ("_TLSLD_MOVW_DTPREL_G0_NC", 527) -- DTPREL(S+A) | Set a MOVK immediate field to bits [15:0] of X. No overflow check+ , ("_TLSLD_ADD_DTPREL_HI12", 528) -- DTPREL(S+A) | Set an ADD immediate field to bits [23:12] of X; check 0 <= X < 2^24+ , ("_TLSLD_ADD_DTPREL_LO12", 529) -- DTPREL(S+A) | Set an ADD immediate field to bits [11:0] of X; check 0 <= X < 2^12+ , ("_TLSLD_ADD_DTPREL_LO12_NC", 530) -- DTPREL(S+A) | Set an ADD immediate field to bits [11:0] of X. No overflow check+ , ("_TLSLD_LDST8_DTPREL_LO12", 531) -- DTPREL(S+A) | Set a LD/ST offset field to bits [11:0] of X; check 0 <= X < 2^12+ , ("_TLSLD_LDST8_DTPREL_LO12_NC", 532) -- DTPREL(S+A) | Set a LD/ST offset field to bits [11:0] of X. No overflow check+ , ("_TLSLD_LDST16_DTPREL_LO12", 533) -- DTPREL(S+A) | Set a LD/ST offset field to bits [11:1] of X; check 0 <= X < 2^12+ , ("_TLSLD_LDST16_DTPREL_LO12_NC", 534) -- DTPREL(S+A) | Set a LD/ST offset field to bits [11:1] of X. No overflow check+ , ("_TLSLD_LDST32_DTPREL_LO12", 535) -- DTPREL(S+A) | Set a LD/ST offset field to bits [11:2] of X; check 0 <= X < 2^12+ , ("_TLSLD_LDST32_DTPREL_LO12_NC", 536) -- DTPREL(S+A) | Set a LD/ST offset field to bits [11:2] of X. No overflow check+ , ("_TLSLD_LDST64_DTPREL_LO12", 537) -- DTPREL(S+A) | Set a LD/ST offset field to bits [11:3] of X; check 0 <= X < 2^12+ , ("_TLSLD_LDST64_DTPREL_LO12_NC", 538) -- DTPREL(S+A) | Set a LD/ST offset field to bits [11:3] of X. No overflow check+ , ("_TLSLD_LDST128_DTPREL_LO12", 572) -- DTPREL(S+A) | Set a LD/ST offset field to bits [11:4] of X; check 0 <= X < 2^12+ , ("_TLSLD_LDST128_DTPREL_LO12_NC", 573) -- DTPREL(S+A) | Set a LD/ST offset field to bits [11:4] of X. No overflow check++ -- Initial Exec TLS relocations++ , ("_TLSIE_MOVW_GOTTPREL_G1", 539) -- G(GTPREL(S+A)) - | GOT Set a MOV[NZ] immediate field to bits [31:16] of X+ , ("_TLSIE_MOVW_GOTTPREL_G0_NC", 540) -- G(GTPREL(S+A)) - | GOT Set MOVK immediate to bits [15:0] of X. No overflow check+ , ("_TLSIE_ADR_GOTTPREL_PAGE21", 541) -- Page(G(GTPREL(S+A))) - Page(P) | Set an ADRP immediate field to bits [32:12] of X; check –2^32 <= X < 2^32+ , ("_TLSIE_LD64_GOTTPREL_LO12_NC", 542) -- G(GTPREL(S+A)) | Set an LD offset field to bits [11:3] of X. No overflow check; check that X&7=0+ , ("_TLSIE_LD_GOTTPREL_PREL19", 543) -- G(GTPREL(S+A)) - P | Set a load-literal immediate to bits [20:2] of X; check –2^20 <= X < 2^20++ -- Local Exec TLS relocations++ , ("_TLSLE_MOVW_TPREL_G2", 544) -- TPREL(S+A) | Set a MOV[NZ] immediate field to bits [47:32] of X+ , ("_TLSLE_MOVW_TPREL_G1", 545) -- TPREL(S+A) | Set a MOV[NZ] immediate field to bits [31:16] of X+ , ("_TLSLE_MOVW_TPREL_G1_NC", 546) -- TPREL(S+A) | Set a MOVK immediate field to bits [31:16] of X. No overflow check+ , ("_TLSLE_MOVW_TPREL_G0", 547) -- TPREL(S+A) | Set a MOV[NZ] immediate field to bits [15:0] of X+ , ("_TLSLE_MOVW_TPREL_G0_NC", 548) -- TPREL(S+A) | Set a MOVK immediate field to bits [15:0] of X. No overflow check+ , ("_TLSLE_ADD_TPREL_HI12", 549) -- TPREL(S+A) | Set an ADD immediate field to bits [23:12] of X; check 0 <= X < 2^24+ , ("_TLSLE_ADD_TPREL_LO12", 550) -- TPREL(S+A) | Set an ADD immediate field to bits [11:0] of X; check 0 <= X < 2^12+ , ("_TLSLE_ADD_TPREL_LO12_NC", 551) -- TPREL(S+A) | Set an ADD immediate field to bits [11:0] of X. No overflow check+ , ("_TLSLE_LDST8_TPREL_LO12", 552) -- TPREL(S+A) | Set a LD/ST offset field to bits [11:0] of X; check 0 <= X < 2^12+ , ("_TLSLE_LDST8_TPREL_LO12_NC", 553) -- TPREL(S+A) | Set a LD/ST offset field to bits [11:0] of X. No overflow check+ , ("_TLSLE_LDST16_TPREL_LO12", 554) -- TPREL(S+A) | Set a LD/ST offset field to bits [11:1] of X; check 0 <= X < 2^12+ , ("_TLSLE_LDST16_TPREL_LO12_NC", 555) -- TPREL(S+A) | Set a LD/ST offset field to bits [11:1] of X. No overflow check+ , ("_TLSLE_LDST32_TPREL_LO12", 556) -- TPREL(S+A) | Set a LD/ST offset field to bits [11:2] of X; check 0 <= X < 2^12+ , ("_TLSLE_LDST32_TPREL_LO12_NC", 557) -- TPREL(S+A) | Set a LD/ST offset field to bits [11:2] of X. No overflow check+ , ("_TLSLE_LDST64_TPREL_LO12", 558) -- TPREL(S+A) | Set a LD/ST offset field to bits [11:3] of X; check 0 <= X < 2^12+ , ("_TLSLE_LDST64_TPREL_LO12_NC", 559) -- TPREL(S+A) | Set a LD/ST offset field to bits [11:3] of X. No overflow check+ , ("_TLSLE_LDST128_TPREL_LO12", 570) -- TPREL(S+A) | Set a LD/ST offset field to bits [11:4] of X; check 0 <= X < 2^12+ , ("_TLSLE_LDST128_TPREL_LO12_NC", 571) -- TPREL(S+A) | Set a LD/ST offset field to bits [11:4] of X. No overflow check++ -- TLS descriptor relocations++ , ("_TLSDESC_LD_PREL19", 560) -- G(GTLSDESC(S+A)) - P | Set a load-literal immediate to bits [20:2]; check -2^20 <= X < 2^20 ; check X & 3 = 0+ , ("_TLSDESC_ADR_PREL21", 561) -- G(GTLSDESC(S+A)) - P | Set an ADR immediate field to bits [20:0]; check -2^20 <= X < 2^20+ , ("_TLSDESC_ADR_PAGE21", 562) -- Page(G(GTLSDESC(S+A))) - Page(P) | Set an ADRP immediate field to bits [32:12] of X; check -2^32 <= X < 2^32+ , ("_TLSDESC_LD64_LO12", 563) -- G(GTLSDESC(S+A)) | Set an LD offset field to bits [11:3] of X. No overflow check; check X & 7 = 0.+ , ("_TLSDESC_ADD_LO12", 564) -- G(GTLSDESC(S+A)) | Set an ADD immediate field to bits [11:0] of X. No overflow check.+ , ("_TLSDESC_OFF_G1", 565) -- G(GTLSDESC(S+A)) - GOT | Set a MOV[NZ] immediate field to bits [31:16] of X; check -2^32 <= X < 2^32.+ , ("_TLSDESC_OFF_G0_NC", 566) -- G(GTLSDESC(S+A)) - GOT | Set a MOVK immediate field to bits [15:0] of X. No overflow check.+ , ("_TLSDESC_LDR", 567) -- None | For relaxation only. Must be used to identify an LDR instruction which loads the TLS descriptor function pointer for S + A if it has no other relocation.+ , ("_TLSDESC_ADD", 568) -- None | For relaxation only. Must be used to identify an ADD instruction which computes the address of the TLS Descriptor for S + A if it has no other relocation.+ , ("_TLSDESC_CALL", 569) -- None | For relaxation only. Must be used to identify a BLR instruction which performs an indirect call to the TLS descriptor function for S + A.++ -- Dynamic relocations++ , ("_COPY", 1024) --+ , ("_GLOB_DAT", 1025) -- S + A+ , ("_JUMP_SLOT", 1026) -- S + A+ , ("_RELATIVE", 1027) -- Delta(S + A)+ , ("_TLS_DTPMOD", 1028) -- DTPREL(S + A)+ , ("_TLS_DTPREL", 1029) -- LDM(S)+ , ("_TLS_TPREL", 1030) -- TPREL(S + A)+ , ("_TLSDESC", 1031) -- TLSDESC(S + A)+ , ("_IRELATIVE", 1032) -- Indirect(Delta(S) + A)++ ])
+ src/Data/Elf/Constants/TH.hs view
@@ -0,0 +1,161 @@+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Elf.Constants.TH ( mkDeclarations+ , BaseWord(..)+ ) where++import Control.Monad+import Language.Haskell.TH++data BaseWord = BaseWord8 | BaseWord16 | BaseWord32 | BaseWord64++newNamePE :: String -> Q (Q Pat, Q Exp)+newNamePE s = do+ n <- newName s+ return (varP n, varE n)++mkDeclarations :: BaseWord -> String -> String -> String -> [(String, Integer)] -> Q [Dec]+mkDeclarations baseType typeNameString patternPrefixString defaultPatternNameString enums = do++ let typeName = mkName typeNameString+ let patternName s = mkName (patternPrefixString ++ s)+ let defaultPatternName = mkName defaultPatternNameString+ let+ baseTypeT =+ case baseType of+ BaseWord8 -> conT $ mkName "Word8"+ BaseWord16 -> conT $ mkName "Word16"+ BaseWord32 -> conT $ mkName "Word32"+ BaseWord64 -> conT $ mkName "Word64"++ let+ newTypeDef =+ newtypeD+ (cxt [])+ typeName+ []+ Nothing+ (normalC typeName [ bangType (bang noSourceUnpackedness noSourceStrictness) baseTypeT ])+ [ derivClause Nothing [ conT (mkName "Eq")+ , conT (mkName "Ord")+ , conT (mkName "Enum")+ , conT (mkName "Num")+ , conT (mkName "Real")+ , conT (mkName "Integral")+ , conT (mkName "Bits")+ , conT (mkName "FiniteBits")+ ]+ ]++ let+ mkShowClause (s, n) =+ clause+ [ conP typeName [litP $ IntegerL n] ]+ (normalB [| patternPrefixString ++ s |])+ []++ let showClauses = map mkShowClause enums++ (nP, nE) <- newNamePE "n"+ let+ defaultShowClause =+ clause+ [ conP typeName [nP] ]+ (normalB [| defaultPatternNameString ++ " " ++ show $(nE) |])+ []++ let showInstanceFunctions = funD (mkName "show") (showClauses ++ [ defaultShowClause ])++ let showInstance = instanceD (cxt []) (appT (conT (mkName "Show")) (conT typeName)) [ showInstanceFunctions ]++ let+ mkBinaryInstance :: Q Type -> Q Pat -> Q Exp -> Q Exp -> Q Dec+ mkBinaryInstance typeT putP putE getE =+ instanceD+ (cxt [])+ (appT (conT (mkName "Binary")) typeT)+ [ binaryInstanceGet, binaryInstancePut ]+ where+ binaryInstancePut =+ funD+ (mkName "put")+ [ clause+ [putP]+ (normalB putE)+ []+ ]+ binaryInstanceGet =+ funD+ (mkName "get")+ [ clause+ []+ (normalB getE)+ []+ ]++ let+ binaryInstancesXe putLe getLe putBe getBe =+ [ do+ (n3P, n3E) <- newNamePE "n"+ mkBinaryInstance+ (appT (conT $ mkName "Le") (conT typeName))+ (conP (mkName "Le") [conP typeName [n3P]])+ [| $putLe $n3E |]+ [| $(conE $ mkName "Le") <$> ($(conE typeName) <$> $getLe) |]+ , do+ (n3P, n3E) <- newNamePE "n"+ mkBinaryInstance+ (appT (conT $ mkName "Be") (conT typeName))+ (conP (mkName "Be") [conP typeName [n3P]])+ [| $putBe $n3E |]+ [| $(conE $ mkName "Be") <$> ($(conE typeName) <$> $getBe) |]+ ]++ let+ binaryInstances =+ case baseType of+ BaseWord8 ->+ [ do+ (n3P, n3E) <- newNamePE "n"+ mkBinaryInstance+ (conT typeName)+ (conP typeName [n3P])+ [| putWord8 $n3E |]+ [| $(conE typeName) <$> getWord8 |]+ ]+ BaseWord16 -> binaryInstancesXe [| putWord16le |] [| getWord16le |] [| putWord16be |] [| getWord16be |]+ BaseWord32 -> binaryInstancesXe [| putWord32le |] [| getWord32le |] [| putWord32be |] [| getWord32be |]+ BaseWord64 -> binaryInstancesXe [| putWord64le |] [| getWord64le |] [| putWord64be |] [| getWord64be |]++ let+ mkPatterns (s, n) =+ [ patSynSigD+ (patternName s)+ (conT typeName)+ , patSynD+ (patternName s)+ (prefixPatSyn [])+ implBidir+ (conP typeName [litP $ IntegerL n])+ ]++ let+ defaultPatternSig =+ patSynSigD+ defaultPatternName+ (appT (appT arrowT baseTypeT) (conT typeName))++ localName3 <- newName "n"++ let+ defaultPatternDef =+ patSynD+ defaultPatternName+ (prefixPatSyn [localName3])+ implBidir+ (conP typeName [varP localName3])++ let patterns = join (map mkPatterns enums) ++ [ defaultPatternSig, defaultPatternDef ]++ sequence $ newTypeDef : showInstance : patterns ++ binaryInstances
+ src/Data/Elf/Headers.hs view
@@ -0,0 +1,698 @@+-- |+-- Module : Data.ELF.Headers+-- Description : Parse headers and table entries of ELF files+-- Copyright : (c) Aleksey Makarov, 2021+-- License : BSD 3-Clause License+-- Maintainer : aleksey.makarov@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- Parse headers and table entries of ELF files++{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTSyntax #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module Data.Elf.Headers (+ -- * Data definition+ elfMagic+ , ElfClass(..)+ , SElfClass (..)+ , ElfData(..)++ , IsElfClass(..)+ , wordSize+ , withElfClass++ -- * Types of ELF header+ , HeaderXX(..)+ , headerSize+ , Header++ -- * Types of ELF tables++ -- ** Section table+ , SectionXX(..)+ , sectionTableEntrySize++ -- ** Segment table+ , SegmentXX(..)+ , segmentTableEntrySize++ -- ** Sybmol table+ , SymbolXX(..)+ , symbolTableEntrySize++ -- ** Relocation table+ , RelaXX(..)+ , relocationTableAEntrySize++ -- * Parse header and section and segment tables+ , HeadersXX (..)+ , parseHeaders++ -- * Parse/serialize array of data++ -- | BList is an internal newtype for @[a]@ that is an instance of `Data.Binary.Binary`.+ -- When serializing, the @Binary@ instance for BList does not write the length of the array to the stream.+ -- Instead, parser just reads all the stream till the end.++ , parseBList+ , serializeBList++ -- * Misc helpers+ , sectionIsSymbolTable++ ) where++-- import Control.Lens hiding (at)+-- import Control.Arrow+import Control.Monad+import Control.Monad.Catch+-- import Control.Monad.State hiding (get, put)+-- import qualified Control.Monad.State as S+import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+import Data.Bits+import Data.ByteString as BS+import Data.ByteString.Lazy as BSL+-- import Data.ByteString.Char8 as BSC+import Data.Data (Data)+import Data.Kind+-- import Data.Kind+import qualified Data.List as L+import Data.Singletons.Sigma+import Data.Singletons.TH+import Data.Typeable (Typeable)+-- import Numeric.Interval as I+-- import Numeric.Interval.NonEmpty as INE++import Control.Exception.ChainedException+import Data.BList+import Data.Endian+import Data.Elf.Constants++-- | ELF class. Tells if ELF defines 32- or 64-bit objects+$(singletons [d|+ data ElfClass+ = ELFCLASS32 -- ^ 32-bit ELF format+ | ELFCLASS64 -- ^ 64-bit ELF format+ deriving (Eq, Show)+ |])++instance Binary ElfClass where+ get = getWord8 >>= getElfClass_+ where+ getElfClass_ 1 = return ELFCLASS32+ getElfClass_ 2 = return ELFCLASS64+ getElfClass_ _ = fail "Invalid ELF class"+ put ELFCLASS32 = putWord8 1+ put ELFCLASS64 = putWord8 2++-- | ELF data. Specifies the endianness of the ELF data+data ElfData+ = ELFDATA2LSB -- ^ Little-endian ELF format+ | ELFDATA2MSB -- ^ Big-endian ELF format+ deriving (Eq, Show)++instance Binary ElfData where+ get = getWord8 >>= getElfData_+ where+ getElfData_ 1 = return ELFDATA2LSB+ getElfData_ 2 = return ELFDATA2MSB+ getElfData_ _ = fail "Invalid ELF data"+ put ELFDATA2LSB = putWord8 1+ put ELFDATA2MSB = putWord8 2++elfSupportedVersion :: Word8+elfSupportedVersion = 1++-- at :: (Integral i) => [a] -> i -> Maybe a+-- at (x : _) 0 = Just x+-- at (_ : xs) n | n > 0 = xs `at` (n - 1)+-- | otherwise = Nothing+-- at _ _ = Nothing++-- nameToString :: Maybe BS.ByteString -> String+-- nameToString bs = maybe "" id $ BSC.unpack <$> bs++-- cut :: BS.ByteString -> Int -> Int -> BS.ByteString+-- cut content offset size = BS.take size $ BS.drop offset content++-- | The first 4 bytes of the ELF file+elfMagic :: Be Word32+elfMagic = Be 0x7f454c46 -- "\DELELF"++verify :: (Binary a, Eq a) => String -> a -> Get ()+verify msg orig = do+ a <- get+ when (orig /= a) $ error ("verification failed: " ++ msg)++-- getTable :: (Binary (Le a), Binary (Be a)) => ElfData -> Word64 -> Word16 -> Word16 -> Get [a]+-- getTable endianness offset entrySize entryNumber = lookAhead $ do+-- skip $ fromIntegral offset+-- getTable' entryNumber+-- where+-- getTable' 0 = return []+-- getTable' n = do+-- a <- isolate (fromIntegral entrySize) $ getEndian endianness+-- (a :) <$> getTable' (n - 1)++getEndian :: (Binary (Le a), Binary (Be a)) => ElfData -> Get a+getEndian ELFDATA2LSB = fromLe <$> get+getEndian ELFDATA2MSB = fromBe <$> get++getBe :: (Binary (Le b), Binary (Be b)) => Get b+getBe = getEndian ELFDATA2MSB++getLe :: (Binary (Le b), Binary (Be b)) => Get b+getLe = getEndian ELFDATA2LSB++putEndian :: (Binary (Le a), Binary (Be a)) => ElfData -> a -> Put+putEndian ELFDATA2LSB = put . Le+putEndian ELFDATA2MSB = put . Be++putBe :: (Binary (Le b), Binary (Be b)) => b -> Put+putBe = putEndian ELFDATA2MSB++putLe :: (Binary (Le b), Binary (Be b)) => b -> Put+putLe = putEndian ELFDATA2LSB++--------------------------------------------------------------------------+-- WordXX+--------------------------------------------------------------------------++-- | @IsElfClass a@ is defined for each constructor of `ElfClass`.+-- It defines @WordXX a@, which is `Word32` for `ELFCLASS32` and `Word64` for `ELFCLASS64`.+type IsElfClass :: ElfClass -> Constraint+class ( SingI c+ , Typeable c+ , Typeable (WordXX c)+ , Data (WordXX c)+ , Show (WordXX c)+ , Read (WordXX c)+ , Eq (WordXX c)+ , Ord (WordXX c)+ , Bounded (WordXX c)+ , Enum (WordXX c)+ , Num (WordXX c)+ , Integral (WordXX c)+ , Real (WordXX c)+ , Bits (WordXX c)+ , FiniteBits (WordXX c)+ , Binary (Be (WordXX c))+ , Binary (Le (WordXX c))+ ) => IsElfClass c where+ type WordXX c = r | r -> c++instance IsElfClass 'ELFCLASS32 where+ type WordXX 'ELFCLASS32 = Word32++instance IsElfClass 'ELFCLASS64 where+ type WordXX 'ELFCLASS64 = Word64++--------------------------------------------------------------------------+-- Header+--------------------------------------------------------------------------++-- | Parsed ELF header+type HeaderXX :: ElfClass -> Type+data HeaderXX c =+ HeaderXX+ { hData :: ElfData -- ^ Data encoding (big- or little-endian)+ , hOSABI :: ElfOSABI -- ^ OS/ABI identification+ , hABIVersion :: Word8 -- ^ ABI version+ , hType :: ElfType -- ^ Object file type+ , hMachine :: ElfMachine -- ^ Machine type+ , hEntry :: WordXX c -- ^ Entry point address+ , hPhOff :: WordXX c -- ^ Program header offset+ , hShOff :: WordXX c -- ^ Section header offset+ , hFlags :: Word32 -- ^ Processor-specific flags+ , hPhEntSize :: Word16 -- ^ Size of program header entry+ , hPhNum :: Word16 -- ^ Number of program header entries+ , hShEntSize :: Word16 -- ^ Size of section header entry+ , hShNum :: Word16 -- ^ Number of section header entries+ , hShStrNdx :: ElfSectionIndex -- ^ Section name string table index+ }++-- | Sigma type where `ElfClass` defines the type of `HeaderXX`+type Header = Sigma ElfClass (TyCon1 HeaderXX)++-- | Size of ELF header.+headerSize :: Num a => ElfClass -> a+headerSize ELFCLASS64 = 64+headerSize ELFCLASS32 = 52++-- | Size of section table entry.+sectionTableEntrySize :: Num a => ElfClass -> a+sectionTableEntrySize ELFCLASS64 = 64+sectionTableEntrySize ELFCLASS32 = 40++-- | Size of segment table entry.+segmentTableEntrySize :: Num a => ElfClass -> a+segmentTableEntrySize ELFCLASS64 = 56+segmentTableEntrySize ELFCLASS32 = 32++-- | Size of symbol table entry.+symbolTableEntrySize :: Num a => ElfClass -> a+symbolTableEntrySize ELFCLASS64 = 24+symbolTableEntrySize ELFCLASS32 = 16++-- | Size of @WordXX a@ in bytes.+wordSize :: Num a => ElfClass -> a+wordSize ELFCLASS64 = 8+wordSize ELFCLASS32 = 4++-- | Convenience function for creating a context with an implicit ElfClass available.+withElfClass :: Sing c -> (IsElfClass c => a) -> a+withElfClass SELFCLASS64 x = x+withElfClass SELFCLASS32 x = x++getHeader' :: IsElfClass c => Sing c -> Get Header+getHeader' classS = do++ hData <- get+ verify "version1" elfSupportedVersion+ hOSABI <- get+ hABIVersion <- get+ skip 7++ let+ getE :: (Binary (Le b), Binary (Be b)) => Get b+ getE = getEndian hData++ hType <- getE+ hMachine <- getE++ (hVersion2 :: Word32) <- getE+ when (hVersion2 /= 1) $ error "verification failed: version2"++ hEntry <- getE+ hPhOff <- getE+ hShOff <- getE++ hFlags <- getE+ (hSize :: Word16) <- getE+ when (hSize /= headerSize (fromSing classS)) $ error "incorrect size of elf header"+ hPhEntSize <- getE+ hPhNum <- getE+ hShEntSize <- getE+ hShNum <- getE+ hShStrNdx <- getE++ return $ classS :&: HeaderXX{..}++getHeader :: Get Header+getHeader = do+ verify "magic" elfMagic+ hClass <- get+ let+ f2 :: forall (c :: ElfClass) . Sing c -> Get Header+ f2 x = withElfClass x (getHeader' x)++ withSomeSing hClass f2++putHeader :: Header -> Put+putHeader (classS :&: HeaderXX{..}) = withElfClass classS do++ put elfMagic+ put $ fromSing classS+ put hData+ put elfSupportedVersion+ put hOSABI+ put hABIVersion++ putByteString $ BS.replicate 7 0++ let+ putE :: (Binary (Le b), Binary (Be b)) => b -> Put+ putE = putEndian hData++ putE hType+ putE hMachine+ putE (1 :: Word32)+ putE hEntry+ putE hPhOff+ putE hShOff+ putE hFlags+ putE (headerSize $ fromSing classS :: Word16)+ putE hPhEntSize+ putE hPhNum+ putE hShEntSize+ putE hShNum+ putE hShStrNdx++instance Binary Header where+ put = putHeader+ get = getHeader++--------------------------------------------------------------------------+-- Section+--------------------------------------------------------------------------++-- | Parsed ELF section table entry+data SectionXX (c :: ElfClass) =+ SectionXX+ { sName :: Word32 -- ^ Section name+ , sType :: ElfSectionType -- ^ Section type+ , sFlags :: WordXX c -- ^ Section attributes+ , sAddr :: WordXX c -- ^ Virtual address in memory+ , sOffset :: WordXX c -- ^ Offset in file+ , sSize :: WordXX c -- ^ Size of section+ , sLink :: Word32 -- ^ Link to other section+ , sInfo :: Word32 -- ^ Miscellaneous information+ , sAddrAlign :: WordXX c -- ^ Address alignment boundary+ , sEntSize :: WordXX c -- ^ Size of entries, if section has table+ }++getSection :: IsElfClass c =>+ (forall b . (Binary (Le b), Binary (Be b)) => Get b) -> Get (SectionXX c)+getSection getE = do++ sName <- getE+ sType <- getE+ sFlags <- getE+ sAddr <- getE+ sOffset <- getE+ sSize <- getE+ sLink <- getE+ sInfo <- getE+ sAddrAlign <- getE+ sEntSize <- getE++ return SectionXX {..}++putSection :: IsElfClass c =>+ (forall b . (Binary (Le b), Binary (Be b)) => b -> Put) ->+ SectionXX c -> Put+putSection putE (SectionXX{..}) = do++ putE sName+ putE sType+ putE sFlags+ putE sAddr+ putE sOffset+ putE sSize+ putE sLink+ putE sInfo+ putE sAddrAlign+ putE sEntSize++instance forall (a :: ElfClass) . SingI a => Binary (Be (SectionXX a)) where+ put = withElfClass (sing @ a) (putSection putBe) . fromBe+ get = Be <$> withElfClass (sing @ a) (getSection getBe)++instance forall (a :: ElfClass) . SingI a => Binary (Le (SectionXX a)) where+ put = withElfClass (sing @ a) (putSection putLe) . fromLe+ get = Le <$> withElfClass (sing @ a) (getSection getLe)++--------------------------------------------------------------------------+-- Segment+--------------------------------------------------------------------------++-- | Parsed ELF segment table entry+data SegmentXX (c :: ElfClass) =+ SegmentXX+ { pType :: ElfSegmentType -- ^ Type of segment+ , pFlags :: ElfSegmentFlag -- ^ Segment attributes+ , pOffset :: WordXX c -- ^ Offset in file+ , pVirtAddr :: WordXX c -- ^ Virtual address in memory+ , pPhysAddr :: WordXX c -- ^ Physical address+ , pFileSize :: WordXX c -- ^ Size of segment in file+ , pMemSize :: WordXX c -- ^ Size of segment in memory+ , pAlign :: WordXX c -- ^ Alignment of segment+ }++getSegment :: forall (c :: ElfClass) . Sing c ->+ (forall b . (Binary (Le b), Binary (Be b)) => Get b) -> Get (SegmentXX c)+getSegment SELFCLASS64 getE = do++ pType <- getE+ pFlags <- getE+ pOffset <- getE+ pVirtAddr <- getE+ pPhysAddr <- getE+ pFileSize <- getE+ pMemSize <- getE+ pAlign <- getE++ return SegmentXX{..}++getSegment SELFCLASS32 getE = do++ pType <- getE+ pOffset <- getE+ pVirtAddr <- getE+ pPhysAddr <- getE+ pFileSize <- getE+ pMemSize <- getE+ pFlags <- getE+ pAlign <- getE++ return SegmentXX{..}++putSegment :: forall (c :: ElfClass) . Sing c ->+ (forall b . (Binary (Le b), Binary (Be b)) => b -> Put) ->+ SegmentXX c -> Put+putSegment SELFCLASS64 putE (SegmentXX{..}) = do++ putE pType+ putE pFlags+ putE pOffset+ putE pVirtAddr+ putE pPhysAddr+ putE pFileSize+ putE pMemSize+ putE pAlign++putSegment SELFCLASS32 putE (SegmentXX{..}) = do++ putE pType+ putE pOffset+ putE pVirtAddr+ putE pPhysAddr+ putE pFileSize+ putE pMemSize+ putE pFlags+ putE pAlign+++instance forall (a :: ElfClass) . SingI a => Binary (Be (SegmentXX a)) where+ put = putSegment sing putBe . fromBe+ get = Be <$> getSegment sing getBe++instance forall (a :: ElfClass) . SingI a => Binary (Le (SegmentXX a)) where+ put = putSegment sing putLe . fromLe+ get = Le <$> getSegment sing getLe++--------------------------------------------------------------------------+-- Symbol table entry+--------------------------------------------------------------------------++-- | Test if the section with such integer value of section type field (`sType`)+-- contains symbol table+sectionIsSymbolTable :: ElfSectionType -> Bool+sectionIsSymbolTable sType = sType `L.elem` [SHT_SYMTAB, SHT_DYNSYM]++-- | Parsed ELF symbol table entry+data SymbolXX (c :: ElfClass) =+ SymbolXX+ { stName :: Word32 -- ^ Symbol name+ , stInfo :: Word8 -- ^ Type and Binding attributes+ , stOther :: Word8 -- ^ Reserved+ , stShNdx :: ElfSectionIndex -- ^ Section table index+ , stValue :: WordXX c -- ^ Symbol value+ , stSize :: WordXX c -- ^ Size of object+ }++getSymbolTableEntry :: forall (c :: ElfClass) . Sing c ->+ (forall b . (Binary (Le b), Binary (Be b)) => Get b) -> Get (SymbolXX c)+getSymbolTableEntry SELFCLASS64 getE = do++ stName <- getE+ stInfo <- get+ stOther <- get+ stShNdx <- getE+ stValue <- getE+ stSize <- getE++ return SymbolXX{..}++getSymbolTableEntry SELFCLASS32 getE = do++ stName <- getE+ stValue <- getE+ stSize <- getE+ stInfo <- get+ stOther <- get+ stShNdx <- getE++ return SymbolXX{..}++putSymbolTableEntry :: forall (c :: ElfClass) . Sing c ->+ (forall b . (Binary (Le b), Binary (Be b)) => b -> Put) ->+ SymbolXX c -> Put+putSymbolTableEntry SELFCLASS64 putE (SymbolXX{..}) = do++ putE stName+ put stInfo+ put stOther+ putE stShNdx+ putE stValue+ putE stSize++putSymbolTableEntry SELFCLASS32 putE (SymbolXX{..}) = do++ putE stName+ putE stValue+ putE stSize+ put stInfo+ put stOther+ putE stShNdx++instance forall (a :: ElfClass) . SingI a => Binary (Be (SymbolXX a)) where+ put = putSymbolTableEntry sing putBe . fromBe+ get = Be <$> getSymbolTableEntry sing getBe++instance forall (a :: ElfClass) . SingI a => Binary (Le (SymbolXX a)) where+ put = putSymbolTableEntry sing putLe . fromLe+ get = Le <$> getSymbolTableEntry sing getLe++--------------------------------------------------------------------------+-- relocation table entry+--------------------------------------------------------------------------++-- | Parsed relocation table entry (@ElfXX_Rela@)+data RelaXX (c :: ElfClass) =+ RelaXX+ { relaOffset :: WordXX c -- ^ Address of reference+ , relaSym :: Word32 -- ^ Symbol table index+ , relaType :: Word32 -- ^ Relocation type+ , relaAddend :: WordXX c -- ^ Constant part of expression+ }++relaSym32 :: Word32 -> Word32+relaSym32 v = v `shiftR` 8++relaType32 :: Word32 -> Word32+relaType32 v = fromIntegral $ v .&. 0xff++relaSym64 :: Word64 -> Word32+relaSym64 v = fromIntegral $ v `shiftR` 32++relaType64 :: Word64 -> Word32+relaType64 v = fromIntegral $ v .&. 0xffffffff++relaInfo32 :: Word32 -> Word32 -> Word32+relaInfo32 s t = (t .&. 0xff) .|. (s `shiftL` 8)++relaInfo64 :: Word32 -> Word32 -> Word64+relaInfo64 s t = fromIntegral t .|. (fromIntegral s `shiftL` 32)++getRelocationTableAEntry :: forall c . IsElfClass c =>+ (forall b . (Binary (Le b), Binary (Be b)) => Get b) -> Get (RelaXX c)+getRelocationTableAEntry getE = do+ relaOffset <- getE+ (relaSym, relaType) <- case sing @ c of+ SELFCLASS64 -> (\x -> (relaSym64 x, relaType64 x)) <$> getE+ SELFCLASS32 -> (\x -> (relaSym32 x, relaType32 x)) <$> getE+ relaAddend <- getE+ return RelaXX{..}++putRelocationTableAEntry :: forall c . IsElfClass c =>+ (forall b . (Binary (Le b), Binary (Be b)) => b -> Put) ->+ RelaXX c -> Put+putRelocationTableAEntry putE (RelaXX{..}) = do+ putE relaOffset+ (case sing @ c of+ SELFCLASS64 -> putE $ relaInfo64 relaSym relaType+ SELFCLASS32 -> putE $ relaInfo32 relaSym relaType) :: Put+ putE relaAddend++instance forall (a :: ElfClass) . SingI a => Binary (Be (RelaXX a)) where+ put = withElfClass (sing @ a) (putRelocationTableAEntry putBe) . fromBe+ get = Be <$> withElfClass (sing @ a) (getRelocationTableAEntry getBe)++instance forall (a :: ElfClass) . SingI a => Binary (Le (RelaXX a)) where+ put = withElfClass (sing @ a) (putRelocationTableAEntry putLe) . fromLe+ get = Le <$> withElfClass (sing @ a) (getRelocationTableAEntry getLe)++-- | Size of @RelaXX a@ in bytes.+relocationTableAEntrySize :: forall a . IsElfClass a => WordXX a+relocationTableAEntrySize = fromIntegral $ BSL.length $ encode $ Le $ RelaXX @ a 0 0 0 0++--------------------------------------------------------------------------+-- parseHeaders+--------------------------------------------------------------------------++elfDecodeOrFail' :: (Binary a, MonadThrow m) => BSL.ByteString -> m (ByteOffset, a)+elfDecodeOrFail' bs = case decodeOrFail bs of+ Left (_, off, err) -> $chainedError $ err ++ " @" ++ show off+ Right (_, off, a) -> return (off, a)++elfDecodeOrFail :: (Binary a, MonadThrow m) => BSL.ByteString -> m a+elfDecodeOrFail bs = snd <$> elfDecodeOrFail' bs++elfDecodeAllOrFail :: (Binary a, MonadThrow m) => BSL.ByteString -> m a+elfDecodeAllOrFail bs = do+ (off, a) <- elfDecodeOrFail' bs+ if off == BSL.length bs then return a else $chainedError $ "leftover != 0 @" ++ show off++-- | Parse an array+parseBList :: (MonadThrow m, Binary (Le a), Binary (Be a))+ => ElfData -- ^ Tells if parser should expect big or little endian data+ -> BSL.ByteString -- ^ Data for parsing+ -> m [a]+parseBList d bs = case d of+ ELFDATA2LSB -> fromBList . fromLe <$> elfDecodeAllOrFail bs+ ELFDATA2MSB -> fromBList . fromBe <$> elfDecodeAllOrFail bs++-- | Serialize an array+serializeBList :: (Binary (Le a), Binary (Be a))+ => ElfData -- ^ Tells if serializer should tread the data as bit or little endian+ -> [a] -- ^ The array to serialize+ -> BSL.ByteString+serializeBList d as = case d of+ ELFDATA2LSB -> encode $ Le $ BList as+ ELFDATA2MSB -> encode $ Be $ BList as++-- FIXME: how to get rid of this? (Can we use some combinators for Sigma)+-- | The type that helps to make the sigma type of the result+-- of the `parseHeaders` function+newtype HeadersXX a = HeadersXX (HeaderXX a, [SectionXX a], [SegmentXX a])++parseHeaders' :: (IsElfClass a, MonadThrow m) => HeaderXX a -> BSL.ByteString -> m (Sigma ElfClass (TyCon1 HeadersXX))+parseHeaders' hxx@HeaderXX{..} bs =+ let+ takeLen off len = BSL.take (fromIntegral len) $ BSL.drop (fromIntegral off) bs+ bsSections = takeLen hShOff (hShEntSize * hShNum)+ bsSegments = takeLen hPhOff (hPhEntSize * hPhNum)+ in do+ ss <- parseBList hData bsSections+ ps <- parseBList hData bsSegments+ return $ sing :&: HeadersXX (hxx, ss, ps)++-- | Parse ELF file and produce header and section and segment tables+parseHeaders :: MonadThrow m => BSL.ByteString -> m (Sigma ElfClass (TyCon1 HeadersXX))+parseHeaders bs = do+ ((classS :&: hxx) :: Header) <- elfDecodeOrFail bs+ withElfClass classS parseHeaders' hxx bs
+ src/Data/Elf/PrettyPrint.hs view
@@ -0,0 +1,498 @@+-- |+-- Module : Data.Elf.PrettyPrint+-- Description : Pretty printing the data parsed by Data.Elf+-- Copyright : (c) Aleksey Makarov, 2021+-- License : BSD 3-Clause License+-- Maintainer : aleksey.makarov@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- Pretty print the data parsed by @Data.Elf@. Basically these functions are used for golden testing.++{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Elf.PrettyPrint+ ( printHeaders+ , printLayout+ , printElf_+ , printElf+ , printStringTable+ , printHeader++ , readFileLazy+ , writeElfDump+ , writeElfLayout++ , splitBits+ ) where++import Control.Monad+import Control.Monad.Catch+import Data.Bits+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy.Char8 as BSL8+import qualified Data.ByteString.Lazy as BSL+import Data.Char+import Data.Int+import qualified Data.List as L+import Data.Singletons+import Data.Singletons.Sigma+import Prettyprinter+import Prettyprinter.Render.Text+import Data.Word+import Numeric+import System.IO++import Control.Exception.ChainedException+import Data.Internal.Elf+import Data.Elf.Constants+import Data.Elf.Headers+import Data.Interval++-- | Splits an integer into list of integers such that its sum equals to the argument,+-- and each element of the list is of the form @(1 << x)@ for some @x@.+-- @splitBits 5@ produces @[ 1, 4 ]@+splitBits :: (Num w, FiniteBits w) => w -> [w]+splitBits w = fmap (shiftL 1) $ L.filter (testBit w) $ fmap (subtract 1) [ 1 .. (finiteBitSize w) ]++formatPairs :: [(String, Doc a)] -> Doc a+formatPairs ls = align $ vsep $ fmap f ls+ where+ f (n, v) = fill w (pretty n <> ":") <+> v+ w = 1 + maximum (fmap (length . fst) ls)++formatList :: [Doc ()] -> Doc ()+formatList = align . vsep . fmap f+ where+ f x = pretty '-' <+> x++padLeadingZeros :: Int -> String -> String+padLeadingZeros n s | length s > n = error "padLeadingZeros args"+ | otherwise = "0x" ++ replicate (n - length s) '0' ++ s++-- printWord8 :: Word8 -> Doc ()+-- printWord8 n = pretty $ padLeadingZeros 2 $ showHex n ""++printWord16 :: Word16 -> Doc ()+printWord16 n = pretty $ padLeadingZeros 4 $ showHex n ""++printWord32 :: Word32 -> Doc ()+printWord32 n = pretty $ padLeadingZeros 8 $ showHex n ""++printWord64 :: Word64 -> Doc ()+printWord64 n = pretty $ padLeadingZeros 16 $ showHex n ""++printWordXXS :: Sing a -> WordXX a -> Doc ()+printWordXXS SELFCLASS32 = printWord32+printWordXXS SELFCLASS64 = printWord64++printWordXX :: SingI a => WordXX a -> Doc ()+printWordXX = withSing printWordXXS++printHeader :: forall a . SingI a => HeaderXX a -> Doc ()+printHeader HeaderXX{..} =+ formatPairs+ [ ("Class", viaShow $ fromSing $ sing @a )+ , ("Data", viaShow hData ) -- ElfData+ , ("OSABI", viaShow hOSABI ) -- ElfOSABI+ , ("ABIVersion", viaShow hABIVersion ) -- Word8+ , ("Type", viaShow hType ) -- ElfType+ , ("Machine", viaShow hMachine ) -- ElfMachine+ , ("Entry", printWordXX hEntry ) -- WordXX c+ , ("PhOff", printWordXX hPhOff ) -- WordXX c+ , ("ShOff", printWordXX hShOff ) -- WordXX c+ , ("Flags", printWord32 hFlags ) -- Word32+ , ("PhEntSize", printWord16 hPhEntSize ) -- Word16+ , ("PhNum", viaShow hPhNum ) -- Word16+ , ("ShEntSize", printWord16 hShEntSize ) -- Word16+ , ("ShNum", viaShow hShNum ) -- Word16+ , ("ShStrNdx", viaShow hShStrNdx ) -- Word16+ ]++printSection :: SingI a => (Int, SectionXX a) -> Doc ()+printSection (n, SectionXX{..}) =+ formatPairs+ [ ("N", viaShow n )+ , ("Name", viaShow sName ) -- Word32+ , ("Type", viaShow sType ) -- ElfSectionType+ , ("Flags", printWordXX sFlags ) -- WordXX c+ , ("Addr", printWordXX sAddr ) -- WordXX c+ , ("Offset", printWordXX sOffset ) -- WordXX c+ , ("Size", printWordXX sSize ) -- WordXX c+ , ("Link", viaShow sLink ) -- Word32+ , ("Info", viaShow sInfo ) -- Word32+ , ("AddrAlign", printWordXX sAddrAlign ) -- WordXX c+ , ("EntSize", printWordXX sEntSize ) -- WordXX c+ ]++printSegment :: SingI a => (Int, SegmentXX a) -> Doc ()+printSegment (n, SegmentXX{..}) =+ formatPairs+ [ ("N", viaShow n )+ , ("Type", viaShow pType ) -- ElfSegmentType+ , ("Flags", viaShow $ splitBits pFlags ) -- ElfSegmentFlag+ , ("Offset", printWordXX pOffset ) -- WordXX c+ , ("VirtAddr", printWordXX pVirtAddr ) -- WordXX c+ , ("PhysAddr", printWordXX pPhysAddr ) -- WordXX c+ , ("FileSize", printWordXX pFileSize ) -- WordXX c+ , ("MemSize", printWordXX pMemSize ) -- WordXX c+ , ("Align", printWordXX pAlign ) -- WordXX c+ ]++-- | Print parsed headers. It's used in golden tests+printHeaders :: SingI a => HeaderXX a -> [SectionXX a] -> [SegmentXX a] -> Doc ()+printHeaders hdr ss ps =+ let+ h = printHeader hdr+ s = fmap printSection (Prelude.zip [0 .. ] ss)+ p = fmap printSegment (Prelude.zip [0 .. ] ps)+ in+ formatPairs+ [ ("Header", h)+ , ("Sections", formatList s)+ , ("Segments", formatList p)+ ]++--------------------------------------------------------------------+--+--------------------------------------------------------------------++printRBuilder :: IsElfClass a => [RBuilder a] -> Doc ()+printRBuilder rbs = vsep ldoc++ where++ mapL f (ix, sx, dx) = (ix, f sx, dx)+ getS (_, sx, _) = sx++ longest [] = 0+ longest rbs' = maximum $ fmap (length . getS) rbs'++ padL n s | length s > n = error "incorrect number of pad symbols for `padL`"+ | otherwise = replicate (n - length s) ' ' ++ s++ equalize l = fmap (mapL (padL l))++ printLine (pos, g, doc) = hsep $ pretty g : printWord32 (fromIntegral pos) : doc+ ls = concatMap printRBuilder' rbs+ len = longest ls+ ldoc = printLine <$> equalize len ls++ printRBuilder' rb = f rb+ where++ i@(I o s) = rBuilderInterval rb++ f RBuilderHeader{} =+ [ (o, "┎", ["H"])+ , (o + s - 1, "┖", [])+ ]+ f RBuilderSectionTable{ rbstHeader = HeaderXX{..} } =+ if hShNum == 0+ then []+ else+ [ (o, "┎", ["ST", parens $ viaShow hShNum])+ , (o + s - 1, "┖", [])+ ]+ f RBuilderSegmentTable{ rbptHeader = HeaderXX{..} } =+ if hPhNum == 0+ then []+ else+ [ (o, "┎", ["PT", parens $ viaShow hPhNum])+ , (o + s - 1, "┖", [])+ ]+ f RBuilderSection{ rbsHeader = SectionXX{..}, ..} =+ let+ doc = [ "S" <> viaShow (fromIntegral rbsN :: Word)+ , dquotes $ pretty rbsName+ , viaShow sType+ , viaShow $ splitBits $ ElfSectionFlag $ fromIntegral sFlags+ ]+ in+ if empty i+ then+ [(o, "-", doc)]+ else+ [(o, "╓", doc)+ ,(o + s - 1, "╙", [])+ ]+ f RBuilderSegment{ rbpHeader = SegmentXX{..}, ..} =+ let+ doc = [ "P"+ , viaShow pType+ , viaShow $ splitBits pFlags+ ]+ in+ if empty i && L.null rbpData+ then+ [(o, "-", doc)]+ else+ let+ xs = concatMap printRBuilder' rbpData+ l = longest xs+ appendSectionBar = fmap (mapL ('│' : ))+ xsf = appendSectionBar $ equalize l xs+ b = '┌' : replicate l '─'+ e = '└' : replicate l '─'+ in+ [(o, b, doc)] +++ xsf +++ [(if empty i then o else o + s - 1, e, [] )]+ f RBuilderRawData{} =+ let+ doc = [ "R" ]+ in+ [(o, "╓", doc)+ ,(o + s - 1, "╙", [])+ ]+ f RBuilderRawAlign{} = []++-- | Print ELF layout. First parse ELF with `parseHeaders`, then use this function to+-- format the layout.+printLayout :: MonadCatch m => Sigma ElfClass (TyCon1 HeadersXX) -> BSL.ByteString -> m (Doc ())+printLayout (classS :&: HeadersXX (hdr, ss, ps)) bs = withElfClass classS do+ rbs <- parseRBuilder hdr ss ps bs+ return $ printRBuilder rbs++--------------------------------------------------------------------+--+--------------------------------------------------------------------++formatPairsBlock :: Doc a -> [(String, Doc a)] -> Doc a+formatPairsBlock name pairs = vsep [ name <+> "{", indent 4 $ formatPairs pairs, "}" ]++printElfSymbolTableEntry :: SingI a => ElfSymbolXX a -> Doc ()+printElfSymbolTableEntry ElfSymbolXX{..} =+ formatPairsBlock ("symbol" <+> dquotes (pretty steName))+ [ ("Bind", viaShow steBind ) -- ElfSymbolBinding+ , ("Type", viaShow steType ) -- ElfSymbolType+ , ("ShNdx", viaShow steShNdx ) -- ElfSectionIndex+ , ("Value", printWordXX steValue ) -- WordXX c+ , ("Size", printWordXX steSize ) -- WordXX c+ ]++printElfSymbolTable :: SingI a => Bool -> [ElfSymbolXX a] -> Doc ()+printElfSymbolTable full l = if full then printElfSymbolTableFull else printElfSymbolTable'+ where+ printElfSymbolTableFull = align . vsep $ fmap printElfSymbolTableEntry l+ printElfSymbolTable' = align . vsep $+ case l of+ (e1 : e2 : _ : _ : _) ->+ [ printElfSymbolTableEntry e1+ , printElfSymbolTableEntry e2+ , "..."+ , printElfSymbolTableEntry $ last l+ , "total:" <+> viaShow (L.length l)+ ]+ _ -> fmap printElfSymbolTableEntry l++splitBy :: Int64 -> BSL.ByteString -> [BSL.ByteString]+splitBy n = L.unfoldr f+ where+ f s | BSL.null s = Nothing+ | otherwise = Just $ BSL.splitAt n s++formatChar :: Char -> Doc ()+formatChar c = pretty $ if isAscii c && not (isControl c) then c else '.'++formatHex :: Word8 -> Doc ()+formatHex w = pretty $ case showHex w "" of+ [ d ] -> [ '0', d ]+ ww -> ww++formatBytestringChar :: BSL.ByteString -> Doc ()+formatBytestringChar = hcat . L.map formatChar . BSL8.unpack++formatBytestringHex :: BSL.ByteString -> Doc ()+formatBytestringHex = hsep . L.map formatHex . BSL.unpack++formatBytestringLine :: BSL.ByteString -> Doc ()+formatBytestringLine s = fill (16 * 2 + 15) (formatBytestringHex s)+ <+> pretty '#'+ <+> formatBytestringChar s++printData :: Bool -> BSL.ByteString -> Doc ()+printData full bs = if full then printDataFull else printData'+ where+ printDataFull = align $ vsep $ L.map formatBytestringLine $ splitBy 16 bs+ printData' = align $ vsep $+ case splitBy 16 bs of+ (c1 : c2 : _ : _ : _) ->+ [ formatBytestringLine c1+ , formatBytestringLine c2+ , "..."+ , formatBytestringLine cl+ , "total:" <+> viaShow (BSL.length bs)+ ]+ chunks -> L.map formatBytestringLine chunks+ cl = BSL.drop (BSL.length bs - 16) bs++printElfSymbolTableEntryLine :: SingI a => ElfSymbolXX a -> Doc ()+printElfSymbolTableEntryLine ElfSymbolXX{..} = parens (dquotes (pretty steName)+ <+> "bind:" <+> viaShow steBind+ <+> "type:" <+> viaShow steType+ <+> "sindex:" <+> viaShow steShNdx+ <+> "value:" <+> printWordXX steValue+ <+> "size:" <+> printWordXX steSize)++printRelocationTableA_AARCH64 :: MonadThrow m => Bool -> Word32 -> [ElfXX 'ELFCLASS64] -> BSL.ByteString -> m (Doc ())+printRelocationTableA_AARCH64 full sLink elfs bs = do+ symTableSection <- elfFindSection elfs sLink+ symTable <- parseSymbolTable ELFDATA2LSB symTableSection elfs+ let+ getSymbolTableEntry' [] _ = $chainedError "wrong symbol table index"+ getSymbolTableEntry' (x:_) 0 = return x+ getSymbolTableEntry' (_:xs) n = getSymbolTableEntry' xs (n - 1)++ getSymbolTableEntry :: MonadThrow m => Word32 -> m (ElfSymbolXX 'ELFCLASS64)+ getSymbolTableEntry = getSymbolTableEntry' symTable++ f :: MonadThrow m => RelaXX 'ELFCLASS64 -> m (Doc ())+ f RelaXX{..} = do+ symbolTableEntry <- getSymbolTableEntry relaSym+ return $ printWord64 relaOffset+ <+> printWord64 relaAddend+ <+> viaShow (ElfRelocationType_AARCH64 relaType)+ <+> printElfSymbolTableEntryLine symbolTableEntry++ split xs = if full then xs else+ case xs of+ (x1 : x2 : _ : _ : _) ->+ [ x1, x2, "...", last xs, "total:" <+> viaShow (length xs) ]+ _ -> xs++ relas <- parseBList ELFDATA2LSB bs+ align . vsep . split <$> mapM f relas++-- | Same as @`printElf_` False@+printElf :: MonadThrow m => Elf -> m (Doc ())+printElf = printElf_ False++-- | 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++ (hData, hMachine) <- do+ header <- elfFindHeader elfs+ case header of+ ElfHeader{..} -> return (ehData, ehMachine)+ _ -> $chainedError "not a header" -- FIXME++ let++ printElf' elfs' = align . vsep <$> mapM printElf'' elfs'++ printElf'' ElfHeader{..} =+ return $ formatPairsBlock "header"+ [ ("Class", viaShow $ fromSing classS )+ , ("Data", viaShow ehData ) -- ElfData+ , ("OSABI", viaShow ehOSABI ) -- ElfOSABI+ , ("ABIVersion", viaShow ehABIVersion ) -- Word8+ , ("Type", viaShow ehType ) -- ElfType+ , ("Machine", viaShow ehMachine ) -- ElfMachine+ , ("Entry", printWordXX ehEntry ) -- WordXX c+ , ("Flags", printWord32 ehFlags ) -- Word32+ ]+ printElf'' s@ElfSection{ esData = (ElfSectionData bs), ..} = do+ (sectionName, dataDoc) <- if sectionIsSymbolTable esType+ then do+ stes <- parseSymbolTable hData s elfs+ return ("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+ SELFCLASS64 -> ("section", ) <$> printRelocationTableA_AARCH64 full esLink elfs bs+ SELFCLASS32 -> $chainedError "invalid ELF: EM_AARCH64 and ELFCLASS32"+ else+ return ("section", printData full bs)+ return $ formatPairsBlock (sectionName <+> viaShow (fromIntegral esN :: Word) <+> dquotes (pretty esName))+ [ ("Type", viaShow esType )+ , ("Flags", viaShow $ splitBits esFlags )+ , ("Addr", printWordXX esAddr )+ , ("AddrAlign", printWordXX esAddrAlign )+ , ("EntSize", printWordXX esEntSize )+ , ("Info", printWord32 esInfo )+ , ("Link", printWord32 esLink )+ , ("Data", dataDoc )+ ]+ printElf'' ElfSection{ esData = ElfSectionDataStringTable, ..} =+ return $ "string table section" <+> viaShow (fromIntegral esN :: Word) <+> dquotes (pretty esName)+ printElf'' ElfSegment{..} = do+ dataDoc <- if null epData+ then return ""+ else do+ dataDoc' <- printElf' epData+ return $ line <> indent 4 dataDoc'+ return $ formatPairsBlock "segment"+ [ ("Type", viaShow epType )+ , ("Flags", viaShow $ splitBits epFlags )+ , ("VirtAddr", printWordXX epVirtAddr )+ , ("PhysAddr", printWordXX epPhysAddr )+ , ("AddMemSize", printWordXX epAddMemSize )+ , ("Align", printWordXX epAlign )+ , ("Data", dataDoc )+ ]+ printElf'' ElfSectionTable = return "section table"+ printElf'' ElfSegmentTable = return "segment table"+ printElf'' ElfRawData{..} =+ return $ formatPairsBlock "raw data"+ [ ("Data", printData full edData)+ ]+ printElf'' ElfRawAlign{..} =+ return $ formatPairsBlock "raw align"+ [ ("Offset", printWordXX eaOffset )+ , ("Align", printWordXX eaAlign )+ ]++ printElf' elfs++--------------------------------------------------------------------+--+--------------------------------------------------------------------++-- | Print string table. It's used in golden tests+printStringTable :: MonadThrow m => BSL.ByteString -> m (Doc ())+printStringTable bs =+ case BSL.unsnoc bs of+ Nothing -> return ""+ Just (bs', e) -> do+ when (e /= 0) $ $chainedError "string table should end with 0"+ return if BSL.length bs' == 0+ then angles ""+ else vsep $ map (angles . pretty) $ L.sort $ map BSL8.unpack $ BSL.splitWith (== 0) bs'++--------------------------------------------------------------------+--+--------------------------------------------------------------------++-- | Read the file strictly but return lazy bytestring+readFileLazy :: FilePath -> IO BSL.ByteString+readFileLazy path = BSL.fromStrict <$> BS.readFile path++-- | Read ELF from one file, `printElf` it into another.+writeElfDump :: FilePath -> FilePath -> IO ()+writeElfDump i o = do+ bs <- readFileLazy i+ e <- parseElf bs+ doc <- printElf e+ withFile o WriteMode (\ h -> hPutDoc h (doc <> line))++-- | Read ELF from one file, `printLayout` it into another.+writeElfLayout :: FilePath -> FilePath -> IO ()+writeElfLayout i o = do+ bs <- readFileLazy i+ hdrs <- parseHeaders bs+ doc <- printLayout hdrs bs+ withFile o WriteMode (\ h -> hPutDoc h (doc <> line))
+ src/Data/Endian.hs view
@@ -0,0 +1,48 @@+-- |+-- Module : Data.Endian+-- Description : Newtypes for little- and big-endian values+-- Copyright : (c) Aleksey Makarov, 2021+-- License : BSD 3-Clause License+-- Maintainer : aleksey.makarov@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- Newtypes for little- and big-endian instances of `Binary`++{-# LANGUAGE FlexibleInstances #-}++module Data.Endian (Be(..), Le(..)) where++import Data.Binary.Put+import Data.Binary.Get+import Data.Binary++-- | @Be a@ is an instance of `Binary` such that @a@ is serialized as big-endian+newtype Be a = Be { fromBe :: a } deriving Eq++-- | @Le a@ is an instance of `Binary` such that @a@ is serialized as little-endian+newtype Le a = Le { fromLe :: a } deriving Eq++instance Binary (Be Word16) where+ put = putWord16be . fromBe+ get = Be <$> getWord16be++instance Binary (Le Word16) where+ put = putWord16le . fromLe+ get = Le <$> getWord16le++instance Binary (Be Word32) where+ put = putWord32be . fromBe+ get = Be <$> getWord32be++instance Binary (Le Word32) where+ put = putWord32le . fromLe+ get = Le <$> getWord32le++instance Binary (Be Word64) where+ put = putWord64be . fromBe+ get = Be <$> getWord64be++instance Binary (Le Word64) where+ put = putWord64le . fromLe+ get = Le <$> getWord64le
+ src/Data/Internal/Elf.hs view
@@ -0,0 +1,986 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTSyntax #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Internal.Elf where++import Control.Exception.ChainedException+import Data.Elf.Constants+import Data.Elf.Headers+import Data.Interval as I++import Control.Monad+import Control.Monad.Catch+import Control.Monad.State as MS+-- import Data.Bifunctor+import Data.Binary+import Data.Bits as Bin+import Data.ByteString.Lazy.Char8 as BSL8+import Data.ByteString.Lazy as BSL+-- import Data.Either+import Data.Foldable+import Data.Int+-- import Data.Kind+import qualified Data.List as L+import Data.Maybe+import Data.Monoid+import Data.Singletons+import Data.Singletons.Sigma+-- import Data.Word++-- 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`+data RBuilder (c :: ElfClass)+ = RBuilderHeader+ { rbhHeader :: HeaderXX c+ }+ | RBuilderSectionTable+ { rbstHeader :: HeaderXX c+ }+ | RBuilderSegmentTable+ { rbptHeader :: HeaderXX c+ }+ | RBuilderSection+ { rbsHeader :: SectionXX c+ , rbsN :: ElfSectionIndex+ , rbsName :: String+ }+ | RBuilderSegment+ { rbpHeader :: SegmentXX c+ , rbpN :: Word16+ , rbpData :: [RBuilder c]+ }+ | RBuilderRawData+ { rbrdInterval :: Interval (WordXX c)+ }+ | RBuilderRawAlign+ { rbraOffset :: WordXX c+ , rbraAlign :: WordXX c+ }++rBuilderInterval :: IsElfClass a => RBuilder a -> Interval (WordXX a)+rBuilderInterval RBuilderHeader{..} = headerInterval rbhHeader+rBuilderInterval RBuilderSectionTable{..} = sectionTableInterval rbstHeader+rBuilderInterval RBuilderSegmentTable{..} = segmentTableInterval rbptHeader+rBuilderInterval RBuilderSection{..} = sectionInterval rbsHeader+rBuilderInterval RBuilderSegment{..} = segmentInterval rbpHeader+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+ findInterval' l [] = LZip l Nothing []+ findInterval' l (x : xs) | e `touches` f x = LZip l (Just x) xs+ | e < offset (f x) = LZip l Nothing (x : xs)+ | otherwise = findInterval' (x : l) xs+ touches a i | I.empty i = a == offset i+ | otherwise = a `member` i++showRBuilder' :: RBuilder a -> String+showRBuilder' RBuilderHeader{} = "header"+showRBuilder' RBuilderSectionTable{} = "section table"+showRBuilder' RBuilderSegmentTable{} = "segment table"+showRBuilder' RBuilderSection{..} = "section " ++ show rbsN+showRBuilder' RBuilderSegment{..} = "segment " ++ show rbpN+showRBuilder' RBuilderRawData{} = "raw data" -- should not be called+showRBuilder' RBuilderRawAlign{} = "alignment" -- should not be called++showRBuilder :: IsElfClass a => RBuilder a -> String+showRBuilder v = showRBuilder' v ++ " (" ++ show (rBuilderInterval v) ++ ")"++-- showERBList :: IsElfClass a => [RBuilder a] -> String+-- showERBList l = "[" ++ (L.concat $ L.intersperse ", " $ fmap showRBuilder l) ++ "]"++intersectMessage :: IsElfClass a => RBuilder a -> RBuilder a -> String+intersectMessage x y = showRBuilder x ++ " and " ++ showRBuilder y ++ " intersect"++addRBuilders :: forall a m . (IsElfClass a, MonadCatch m) => [RBuilder a] -> m [RBuilder a]+addRBuilders newts =+ let+ addRBuilders' f newts' l = foldM (flip f) l newts'++ addRBuilderEmpty :: (IsElfClass a, MonadCatch m) => RBuilder a -> [RBuilder a] -> m [RBuilder a]+ 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++ -- 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`,+ -- `lo` is the rest of `l`.+ allEmptyStartingAt :: WordXX a -> [RBuilder a] -> ([RBuilder a], [RBuilder a])+ allEmptyStartingAt a ls = f ([], ls)+ where+ f (le, []) = (L.reverse le, [])+ f (le, h : lo) =+ let+ hi = rBuilderInterval h+ in if not (I.empty hi) || (offset hi /= a)+ then (L.reverse le, h : lo)+ else f (h : le, lo)+ in case c' of+ Just RBuilderSegment{..} -> do+ d <- $addContext' $ addRBuilderEmpty t rbpData+ return $ toList $ LZip l (Just RBuilderSegment{ rbpData = d, .. }) r+ Just c ->+ if offset (rBuilderInterval c) /= to then+ $chainedError $ intersectMessage t c+ else+ let+ (ce, re) = allEmptyStartingAt to (c : r)+ in case t of+ RBuilderSegment{..} ->+ return $ toList $ LZip l (Just RBuilderSegment{ rbpData = ce, .. }) 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]+ addRBuilderNonEmpty t ts =+ -- (unsafePerformIO $ Prelude.putStrLn $ "Add NonEmpty " ++ showRBuilder t ++ " to " ++ showERBList ts) `seq`+ let+ ti = rBuilderInterval t+ (LZip l c' r) = findInterval rBuilderInterval (offset ti) ts++ addRBuildersNonEmpty :: (IsElfClass a, MonadCatch m) => [RBuilder a] -> RBuilder a -> m (RBuilder a)+ addRBuildersNonEmpty [] x = return x+ addRBuildersNonEmpty ts' RBuilderSegment{..} = do+ d <- $addContext' $ addRBuilders' addRBuilderNonEmpty ts' rbpData+ return RBuilderSegment{ rbpData = d, .. }+ addRBuildersNonEmpty (x:_) y = $chainedError $ intersectMessage x y++ in case c' of++ Just c ->++ if ti == rBuilderInterval c then++ case t of++ -- NB: If a segment A has number greater than segment B and they have same size, then+ -- segment A contains segment B+ -- This should be taken into account in the serialization code.+ RBuilderSegment{..} ->++ return $ toList $ LZip l (Just RBuilderSegment{ rbpData = [c], .. }) r++ _ -> do++ c'' <- $addContext' $ addRBuildersNonEmpty [t] c+ return $ toList $ LZip l (Just c'') r++ else if rBuilderInterval c `contains` ti then do++ c'' <- $addContext' $ addRBuildersNonEmpty [t] c+ return $ toList $ LZip l (Just c'') r++ else if ti `contains` rBuilderInterval c then++ let++ tir = offset ti + size ti - 1+ (LZip l2 c2' r2) = findInterval rBuilderInterval tir r++ in case c2' of++ Nothing -> do++ -- add this: ......[t__________________________]...................+ -- to this list: ......[c__]......[l2__]...[l2__].....[________].......+ -- no need to keep the order of l2 as each member of the list will be placed independently from scratch+ c'' <- $addContext' $ addRBuildersNonEmpty (c : l2) t+ return $ toList $ LZip l (Just c'') r2++ Just c2 ->++ if ti `contains` rBuilderInterval c2 then do++ -- add this: ......[t______________________]........................+ -- to this list: ......[c_________]......[c2___]......[________]........+ c'' <- $addContext' $ addRBuildersNonEmpty (c : c2 : l2) t+ return $ toList $ LZip l (Just c'') r2+ else++ -- add this: ......[t_________________].............................+ -- to this list: ......[c_________]......[c2___]......[________]........+ $chainedError $ intersectMessage t c2++ else++ -- add this: ..........[t________].............................+ -- to this list: ......[c_________]......[_____]......[________]...+ $chainedError $ intersectMessage t c++ Nothing ->++ let+ tir = offset ti + size ti - 1+ (LZip l2 c2' r2) = findInterval rBuilderInterval tir r+ in case c2' of++ Nothing -> do++ -- add this: ....[t___].........................................+ -- or this: ....[t_________________________]...................+ -- to this list: .............[l2__]...[l2__].....[________]........+ c'' <- $addContext' $ addRBuildersNonEmpty l2 t+ return $ toList $ LZip l (Just c'') r2++ Just c2 ->++ if ti `contains` rBuilderInterval c2 then do++ -- add this: ....[t_________________________________]........+ -- to this list: ..........[l2__]..[l2__].....[c2_______]........+ c'' <- $addContext' $ addRBuildersNonEmpty (c2 : l2) t+ return $ toList $ LZip l (Just c'') r2++ else++ -- add this: ....[t_______________________________]..........+ -- to this list: ..........[l2__]..[l2__].....[c2_______]........+ $chainedError $ intersectMessage t c2++ (emptyRBs, nonEmptyRBs) = L.partition (I.empty . rBuilderInterval) newts++ in+ addRBuilders' addRBuilderNonEmpty nonEmptyRBs [] >>= addRBuilders' addRBuilderEmpty emptyRBs++-- | `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+ = ElfSectionData BSL.ByteString -- ^ Regular section data+ | ElfSectionDataStringTable -- ^ Section data will be generated from section names++-- | The type of node that defines Elf structure.+data ElfXX (c :: ElfClass)+ = 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 -- ^ 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+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 s@ElfSection{..} | esN == fromIntegral 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+elfFindHeader elfs = $maybeAddContext "no header" maybeHeader+ where+ maybeHeader = getFirst $ foldMapElfList f elfs+ f h@ElfHeader{} = First $ Just h+ f _ = First Nothing++-- | Get string from string table+getString :: BSL.ByteString -- ^ Section data of a string table section+ -> Int64 -- ^ Offset to the start of the string in that data+ -> String+getString bs offset = BSL8.unpack $ BSL.takeWhile (/= 0) $ BSL.drop offset bs++cut :: BSL.ByteString -> Int64 -> Int64 -> BSL.ByteString+cut content offset size = BSL.take size $ BSL.drop offset content++-- | Get section data+getSectionData :: IsElfClass a+ => BSL.ByteString -- ^ ELF file+ -> SectionXX a -- ^ Parsed section entry+ -> BSL.ByteString -- ^ Section Data+getSectionData bs SectionXX{..} = cut bs o s+ where+ o = fromIntegral sOffset+ s = fromIntegral sSize++tail' :: [a] -> [a]+tail' [] = []+tail' (_ : xs) = xs++nextOffset :: IsElfClass a => WordXX a -> WordXX a -> WordXX a -> WordXX a+nextOffset _ 0 a = a+nextOffset t m a | m .&. (m - 1) /= 0 = error $ "align module is not power of two " ++ show m+ | otherwise = if a' + t' < a then a' + m + t' else a' + t'+ where+ a' = a .&. complement (m - 1)+ t' = t .&. (m - 1)++addRawData :: forall a . IsElfClass a => BSL.ByteString -> [RBuilder a] -> [RBuilder a]+addRawData _ [] = []+addRawData bs rBuilders = snd $ addRawData' 0 (lrbie, rBuilders)+ where++ -- e, e', ee and lrbie stand for the first occupied byte after the place being fixed+ -- lrbi: last rBuilder interval (begin, size)+ lrbi@(I lrbib lrbis) = rBuilderInterval $ L.last rBuilders+ lrbie = if I.empty lrbi then lrbib else lrbib + lrbis++ allEmpty :: WordXX a -> WordXX a -> Bool+ allEmpty b s = BSL.all (== 0) bs'+ where+ bs' = cut bs (fromIntegral b) (fromIntegral s)++ addRawData' :: WordXX a -> (WordXX a, [RBuilder a]) -> (WordXX a, [RBuilder a])+ addRawData' alignHint (e, rbs) = L.foldr f (e, []) $ fmap fixRBuilder rbs+ where+ f rb (e', rbs') =+ let+ i@(I b s) = rBuilderInterval rb+ b' = if I.empty i then b else b + s+ rbs'' = addRaw b' e' rbs'+ in+ (b, rb : rbs'')++ fixRBuilder :: RBuilder a -> RBuilder a+ fixRBuilder p | I.empty $ rBuilderInterval p = p+ fixRBuilder p@RBuilderSegment{..} =+ RBuilderSegment{ rbpData = addRaw b ee' rbs', ..}+ where+ (I b s) = rBuilderInterval p+ ee = b + s+ alignHint' = max (pAlign rbpHeader) alignHint+ (ee', rbs') = addRawData' alignHint' (ee, rbpData)+ fixRBuilder x = x++ -- b is the first free byte+ addRaw :: WordXX a -> WordXX a -> [RBuilder a] -> [RBuilder a]+ addRaw b ee rbs' =+ if b < ee+ then+ if not $ allEmpty b s+ then+ RBuilderRawData (I b s) : rbs'+ else+ -- check e' < ee means+ -- check if next section/segment was actually placed (ee) with greater offset+ -- than is required by alignment rules (e')+ if e' < ee && e'' == ee+ then+ RBuilderRawAlign ee alignHint : rbs'+ else+ rbs'+ else+ rbs'+ where+ s = ee - b+ eAddr = case rbs' of+ (RBuilderSegment{rbpHeader = SegmentXX{..}} : _) -> pVirtAddr+ _ -> 0+ eAddrAlign = case rbs' of+ (RBuilderSegment{rbpHeader = SegmentXX{..}} : _) -> pAlign+ (RBuilderSection{rbsHeader = SectionXX{..}} : _) -> sAddrAlign+ _ -> wordSize $ fromSing $ sing @a+ -- e' here is the address of the next section/segment+ -- according to the regular alignment rules+ e' = nextOffset eAddr eAddrAlign b+ e'' = nextOffset ee alignHint b++infix 9 !!?++(!!?) :: (Integral b) => [a] -> b -> Maybe a+(!!?) xs i+ | i < 0 = Nothing+ | otherwise = go i xs+ where+ go :: (Integral b) => b -> [a] -> Maybe a+ go 0 (x:_) = Just x+ go j (_:ys) = go (j - 1) ys+ go _ [] = Nothing++-- | Parse ELF file and produce [`RBuilder`]+parseRBuilder :: (IsElfClass a, MonadCatch m)+ => HeaderXX a -- ^ ELF header+ -> [SectionXX a] -- ^ Section table+ -> [SegmentXX a] -- ^ Segment table+ -> BSL.ByteString -- ^ ELF file+ -> m [RBuilder a]+parseRBuilder hdr@HeaderXX{..} ss ps bs = do+++ let+ maybeStringSectionData = getSectionData bs <$> (ss !!? hShStrNdx)++ mkRBuilderSection :: (SingI a, MonadCatch m) => (ElfSectionIndex, SectionXX a) -> m (RBuilder a)+ mkRBuilderSection (n, s@SectionXX{..}) = do+ stringSectionData <- $maybeAddContext "No string table" maybeStringSectionData+ return $ RBuilderSection s n $ getString stringSectionData $ fromIntegral sName++ mkRBuilderSegment :: (SingI a, MonadCatch m) => (Word16, SegmentXX a) -> m (RBuilder a)+ mkRBuilderSegment (n, p) = return $ RBuilderSegment p n []++ sections <- mapM mkRBuilderSection $ tail' $ Prelude.zip [0 .. ] ss+ segments <- mapM mkRBuilderSegment $ Prelude.zip [0 .. ] ps++ let++ header = RBuilderHeader hdr+ maybeSectionTable = if hShNum == 0 then Nothing else Just $ RBuilderSectionTable hdr+ maybeSegmentTable = if hPhNum == 0 then Nothing else Just $ RBuilderSegmentTable hdr++ rbs <- addRBuilders $ [header] ++ maybeToList maybeSectionTable+ ++ maybeToList maybeSegmentTable+ ++ segments+ ++ sections+ return $ addRawData bs rbs++parseElf' :: forall a m . (IsElfClass a, MonadCatch m) =>+ HeaderXX a ->+ [SectionXX a] ->+ [SegmentXX a] ->+ BSL.ByteString -> m Elf+parseElf' hdr@HeaderXX{..} ss ps bs = do++ rbs <- parseRBuilder hdr ss ps bs++ let+ rBuilderToElf :: RBuilder a -> m (ElfXX a)+ rBuilderToElf RBuilderHeader{} =+ return ElfHeader+ { ehData = hData+ , ehOSABI = hOSABI+ , ehABIVersion = hABIVersion+ , ehType = hType+ , ehMachine = hMachine+ , ehEntry = hEntry+ , ehFlags = hFlags+ }+ rBuilderToElf RBuilderSectionTable{} =+ return ElfSectionTable+ rBuilderToElf RBuilderSegmentTable{} =+ return ElfSegmentTable+ rBuilderToElf RBuilderSection{ rbsHeader = s@SectionXX{..}, ..} =+ return ElfSection+ { esName = rbsName+ , esType = sType+ , esFlags = fromIntegral sFlags+ , esAddr = sAddr+ , esAddrAlign = sAddrAlign+ , esEntSize = sEntSize+ , esN = rbsN+ , esInfo = sInfo+ , esLink = sLink+ , esData = if rbsN == hShStrNdx+ then+ ElfSectionDataStringTable+ else+ ElfSectionData if I.empty $ sectionInterval s+ then BSL.empty+ else getSectionData bs s+ }+ rBuilderToElf RBuilderSegment{ rbpHeader = SegmentXX{..}, ..} = do+ d <- mapM rBuilderToElf rbpData+ addMemSize <- if pMemSize /= 0 && pFileSize /= 0 && pMemSize < pFileSize+ then $chainedError "memSize < fileSize"+ else return (pMemSize - pFileSize)+ return ElfSegment+ { epType = pType+ , epFlags = pFlags+ , epVirtAddr = pVirtAddr+ , epPhysAddr = pPhysAddr+ , 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++ el <- mapM rBuilderToElf rbs+ return $ sing :&: ElfList el++-- | Parse ELF file+parseElf :: MonadCatch m => BSL.ByteString -> m Elf+parseElf bs = do+ classS :&: HeadersXX (hdr, ss, ps) <- parseHeaders bs+ withElfClass classS parseElf' hdr ss ps bs++-------------------------------------------------------------------------------+--+-------------------------------------------------------------------------------++data WBuilderData+ = WBuilderDataHeader+ | WBuilderDataByteStream { wbdData :: BSL.ByteString }+ | WBuilderDataSectionTable+ | WBuilderDataSegmentTable++data WBuilderState (a :: ElfClass) =+ 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 = []+ }++zeroSection :: forall a . IsElfClass a => SectionXX a+zeroSection = SectionXX 0 0 0 0 0 0 0 0 0 0++neighbours :: [a] -> (a -> a -> b) -> [b]+neighbours [] _ = []+neighbours x f = fmap (uncurry f) $ L.zip x $ L.tail x++-- make string table and indexes for it from a list of strings+mkStringTable :: [String] -> (BSL.ByteString, [Int64])+mkStringTable sectionNames = (stringTable, os)+ where++ -- names:+ -- i for indexes of the section entry in section table+ -- n for section name string+ -- o for offset of the string in the string table+ -- in, io -- for pairs+ -- ins, ios -- for lists of pairs+ -- etc++ (ins0, ins) = L.break ((/= "") . snd) $ L.sortOn (L.length . snd) $ L.zip [(1 :: Word32) .. ] sectionNames+ ios0 = fmap f' ins0+ where+ f' (i, _) = (i, 0)++ (stringTable, ios, _) = f (BSL.singleton 0, [], L.reverse ins)++ os = fmap snd $ L.sortOn fst $ ios0 ++ ios++ -- create string table. If one name is a suffix of another,+ -- allocate only the longest name in string table+ f x@(_, _, []) = x+ f (st, iosf, (i, n) : insf) = f (st', iosf'', insf')++ where++ st' = st <> BSL8.pack n <> BSL.singleton 0+ o = BSL.length st+ iosf'' = (i, o) : iosf' ++ iosf++ (iosf', insf') = ff insf++ -- look if there exists a name that is a suffix for the currently allocated name+ -- in the list of unallocated indexed section names+ ff = L.foldr fff ([], [])+ where+ fff (i', n') (iosff, insff) = if n' `L.isSuffixOf` n+ then+ let+ o' = o + fromIntegral (L.length n - L.length n')+ in+ ((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' elfs = do++ (header', hData') <- do+ header <- elfFindHeader elfs+ case header of+ ElfHeader{..} -> return (header, ehData)+ _ -> $chainedError "not a header" -- FIXME++ let++ elfClass = fromSing $ sing @a++ sectionN :: Num b => b+ sectionN = getSum $ foldMapElfList f elfs+ where+ f ElfSection{} = Sum 1+ f _ = Sum 0++ sectionNames :: [String]+ sectionNames = foldMapElfList f elfs+ where+ f ElfSection{..} = [ esName ]+ f _ = []++ (stringTable, nameIndexes) = mkStringTable sectionNames++ segmentN :: Num b => b+ segmentN = getSum $ foldMapElfList f elfs+ where+ f ElfSegment{} = Sum 1+ f _ = Sum 0++ sectionTable :: Bool+ sectionTable = getAny $ foldMapElfList f elfs+ where+ 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'+ , ..+ }++ alignWord :: MonadThrow n => WBuilderState a -> n (WBuilderState a)+ alignWord = align 0 $ wordSize $ fromSing $ sing @a++ dataIsEmpty :: ElfSectionData -> Bool+ dataIsEmpty (ElfSectionData bs) = BSL.null bs+ dataIsEmpty ElfSectionDataStringTable = BSL.null stringTable++ lastSectionIsEmpty :: [ElfXX a] -> Bool+ lastSectionIsEmpty [] = False+ lastSectionIsEmpty l = case L.last l of+ ElfSection{..} -> esType == SHT_NOBITS || dataIsEmpty esData+ _ -> False++ 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")+ WBuilderState{..} <- if esType == SHT_NOBITS+ then return s+ else align 0 esAddrAlign s+ let+ (d, shStrNdx) = case esData of+ ElfSectionData bs -> (bs, wbsShStrNdx)+ ElfSectionDataStringTable -> (stringTable, esN)+ (n, ns) = case wbsNameIndexes of+ n' : ns' -> (n', ns')+ _ -> error "internal error: different number of sections in two iterations"+ sName = fromIntegral n -- Word32+ sType = esType -- ElfSectionType+ sFlags = fromIntegral f+ sAddr = esAddr -- WXX c+ sOffset = wbsOffset -- WXX c+ sSize = fromIntegral $ BSL.length d -- 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'+ 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+ pType = epType+ pFlags = epFlags+ pOffset = offset+ pVirtAddr = epVirtAddr+ pPhysAddr = epPhysAddr+ pFileSize = wbsOffset - 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++ fixSections :: [(ElfSectionIndex, SectionXX a)] -> m [SectionXX a]+ fixSections ss = do+ when (L.length ss /= sectionN) (error "internal error: L.length ss /= sectionN")+ let+ f (ln, _) (rn, _) = ln `compare` rn+ sorted = L.sortBy f ss+ next (ln, _) (rn, _) = ln + 1 == rn+ checkNeibours = and $ neighbours sorted next++ unless checkNeibours ($chainedError "sections are not consistent")+ return $ fmap snd sorted++ wbState2ByteString :: WBuilderState a -> m BSL.ByteString+ wbState2ByteString WBuilderState{..} = do++ sections <- fixSections wbsSections++ let+ f WBuilderDataHeader =+ case header' of+ ElfHeader{..} ->+ let+ hData = ehData+ hOSABI = ehOSABI+ hABIVersion = ehABIVersion+ hType = ehType+ hMachine = ehMachine+ hEntry = ehEntry+ hPhOff = wbsPhOff+ hShOff = wbsShOff+ hFlags = ehFlags+ hPhEntSize = segmentTableEntrySize elfClass+ hPhNum = segmentN+ hShEntSize = sectionTableEntrySize elfClass+ hShNum = if sectionTable then sectionN + 1 else 0+ 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+ f WBuilderDataSegmentTable =+ serializeBList hData' $ L.reverse wbsSegmentsReversed++ return $ foldMap f $ L.reverse wbsDataReversed++ execStateT (mapM elf2WBuilder elfs) wbStateInit{ wbsNameIndexes = nameIndexes } >>= wbState2ByteString++-- | Serialze ELF file+serializeElf :: MonadThrow m => Elf -> m BSL.ByteString+serializeElf (classS :&: ElfList ls) = withElfClass classS serializeElf' ls++-------------------------------------------------------------------------------+--+-------------------------------------------------------------------------------++-- FIXME: move this to a separate file++-- | Parsed ELF symbol table entry. NB: This is work in progress+data ElfSymbolXX (c :: ElfClass) =+ ElfSymbolXX+ { steName :: String -- ^ Symbol name (NB: String, not string index)+ , steBind :: ElfSymbolBinding -- ^ Symbol binding attributes+ , steType :: ElfSymbolType -- ^ Symbol Type+ , steShNdx :: ElfSectionIndex -- ^ Section table index+ , steValue :: WordXX c -- ^ Symbol value+ , steSize :: WordXX c -- ^ Size of object+ }++getStringFromData :: BSL.ByteString -> Word32 -> String+getStringFromData stringTable offset = BSL8.unpack $ BSL.takeWhile (/= 0) $ BSL.drop (fromIntegral offset) stringTable++mkElfSymbolTableEntry :: SingI a => BSL.ByteString -> SymbolXX a -> ElfSymbolXX a+mkElfSymbolTableEntry stringTable SymbolXX{..} =+ let+ steName = getStringFromData stringTable stName+ steBind = ElfSymbolBinding $ stInfo `shiftR` 4+ steType = ElfSymbolType $ stInfo .&. 0x0f+ steShNdx = stShNdx+ steValue = stValue+ steSize = stSize+ in+ ElfSymbolXX{..}++-- | 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+ -> m [ElfSymbolXX a] -- ^ Symbol table+parseSymbolTable d ElfSection{ esData = ElfSectionData symbolTable, ..} elfs = do+ 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++mkSymbolTableEntry :: SingI a => Word32 -> ElfSymbolXX a -> SymbolXX a+mkSymbolTableEntry nameIndex ElfSymbolXX{..} =+ let+ ElfSymbolBinding b = steBind+ ElfSymbolType t = steType++ stName = nameIndex+ stInfo = b `shift` 4 .|. t+ stOther = 0+ stShNdx = steShNdx+ stValue = steValue+ stSize = steSize+ in+ SymbolXX{..}++-- | Serialize symbol table+serializeSymbolTable :: (MonadThrow m, SingI a)+ => ElfData -- ^ Endianness of the ELF file+ -> [ElfSymbolXX a] -- ^ Symbol table+ -> m (BSL.ByteString, BSL.ByteString) -- ^ Pair of symbol table section data and string table section data+serializeSymbolTable d ss = do++ let+ (stringTable, stringIndexes) = mkStringTable $ fmap steName ss+ ssWithNameIndexes = L.zip ss stringIndexes++ f :: SingI a => (ElfSymbolXX a, Int64) -> SymbolXX a+ f (s, n) = mkSymbolTableEntry (fromIntegral n) s++ symbolTable = serializeBList d $ fmap f ssWithNameIndexes++ return (symbolTable, stringTable)
+ src/Data/Interval.hs view
@@ -0,0 +1,35 @@+-- This differs from intervals package: even an empty interval has offset (but not inf)++module Data.Interval+ ( Interval(..)+ , member+ , empty+ , contains+ ) where++data Interval a = I { offset :: !a, size :: !a }++instance (Ord a, Eq 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++instance (Ord a, Num a, Show a) => Show (Interval a) where+ show (I o s) | s <= 0 = "empty @" ++ show o+ | otherwise = show o ++ " ... " ++ show (o + s - 1)++empty :: (Ord a, Num a) => Interval a -> Bool+empty (I _ s) | s <= 0 = True+ | otherwise = False+{-# INLINE empty #-}++member :: (Ord a, Num a) => a -> Interval a -> Bool+member x i@(I o s) | empty i = False+ | otherwise = o <= x && x <= (o + s - 1)+{-# INLINE member #-}++contains :: (Ord a, Num a) => Interval a -> Interval a -> Bool+contains b a@(I ao as) | empty b = False+ | empty a = ao `member` b+ | otherwise = ao `member` b && (ao + as - 1) `member` b+{-# INLINE contains #-}
+ tests/Golden.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Main (main) where++-- import Paths_elf+import Prelude as P++import Control.Monad+import Control.Monad.Catch+import Data.Binary+import qualified Data.ByteString as BS+import Data.ByteString.Lazy as BSL+-- import Data.ByteString.Lazy.Char8 as BSC+import Data.Foldable as F+-- import Data.Functor.Identity+import Data.Int+import Data.Singletons+import Data.Singletons.Sigma+import Prettyprinter+import Prettyprinter.Render.Text+import System.Directory+import System.FilePath+import System.IO as IO+import Test.Tasty+import Test.Tasty.Golden+import Test.Tasty.HUnit++import Control.Exception.ChainedException+import Data.Elf+import Data.Elf.PrettyPrint+import Data.Elf.Headers+import Data.Endian++partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])+partitionM p = foldlM f ([], [])+ where+ f (ts, fs) x = do+ b <- p x+ return $ if b then (x:ts, fs) else (ts, x:fs)++traverseDir :: FilePath -> (FilePath -> IO Bool) -> IO [FilePath]+traverseDir root ok = go root+ where+ go :: FilePath -> IO [FilePath]+ go dir = do+ paths <- P.map (dir </>) <$> listDirectory dir+ (dirPaths, filePaths) <- partitionM doesDirectoryExist paths+ oks <- filterM ok filePaths+ (oks ++) <$> (F.concat <$> mapM go dirPaths)++isElf :: FilePath -> IO Bool+isElf p = if takeExtension p == ".bad" then return False else (elfMagic ==) . decode <$> BSL.readFile p++decodeOrFailAssertion :: Binary a => ByteString -> IO (Int64, a)+decodeOrFailAssertion bs = case decodeOrFail bs of+ Left (_, off, err) -> assertFailure (err ++ " @" ++ show off)+ Right (_, off, a) -> return (off, a)++mkTest'' :: forall a . IsElfClass a => HeaderXX a -> ByteString -> Assertion+mkTest'' HeaderXX{..} bs = do++ let+ takeLen off len = BSL.take (fromIntegral len) $ BSL.drop (fromIntegral off) bs+ bsSections = takeLen hShOff (hShEntSize * hShNum)+ bsSegments = takeLen hPhOff (hPhEntSize * hPhNum)++ (ss :: [SectionXX a]) <- parseBList hData bsSections+ assertEqual "Section table round trip does not work" bsSections $ serializeBList hData ss++ (ps :: [SegmentXX a]) <- parseBList hData bsSegments+ assertEqual "Segment table round trip does not work" bsSegments $ serializeBList hData ps++mkTest' :: ByteString -> Assertion+mkTest' bs = do+ (off, elfh@(classS :&: hxx) :: Header) <- decodeOrFailAssertion bs+ assertBool "Incorrect header size" (headerSize (fromSing classS) == off)+ assertEqual "Header round trip does not work" (BSL.take off bs) (encode elfh)++ withElfClass classS mkTest'' hxx bs++mkTest :: FilePath -> TestTree+mkTest p = testCase p $ withBinaryFile p ReadMode (BSL.hGetContents >=> mkTest')++mkGoldenTest' :: FilePath -> FilePath -> (FilePath -> IO (Doc ())) -> FilePath -> TestTree+mkGoldenTest' g o formatFunction file = goldenVsFile file g o mkGoldenTestOutput+ where+ mkGoldenTestOutput :: IO ()+ mkGoldenTestOutput = do+ doc <- formatFunction file+ withFile o WriteMode (`hPutDoc` doc)++mkGoldenTest :: String -> (FilePath -> IO (Doc ())) -> FilePath -> TestTree+mkGoldenTest name formatFunction file = mkGoldenTest' g o formatFunction file+ where+ newBase = "tests" </> file <.> name+ o = newBase <.> "out"+ g = newBase <.> "golden"++mkGoldenTestOSuffix :: String -> String -> (FilePath -> IO (Doc ())) -> FilePath -> TestTree+mkGoldenTestOSuffix name osuffix formatFunction file = mkGoldenTest' g o formatFunction file+ where+ newBase = "tests" </> file <.> name+ o = newBase <.> osuffix <.> "out"+ g = newBase <.> "golden"++------------------------------------------------------------------------------++-- FIXME: define foldMapRBuilderList++index' :: (Integral i, MonadThrow m) => [a] -> i -> m a+index' (x:_) 0 = return x+index' (_:xs) n | n > 0 = index' xs (n-1)+ | otherwise = $chainedError "index': negative argument."+index' _ _ = $chainedError "index': index too large."++getStringTable :: MonadThrow m => Sigma ElfClass (TyCon1 HeadersXX) -> BSL.ByteString -> m BSL.ByteString+getStringTable (classS :&: HeadersXX (HeaderXX{..}, ss, _)) bs = withElfClass classS+ if hShStrNdx == 0+ then return BSL.empty+ else do+ strs <- index' ss hShStrNdx+ return $ getSectionData bs strs++copyElf :: MonadCatch m => BSL.ByteString -> m BSL.ByteString+copyElf bs = parseElf bs >>= serializeElf++---------------------------------------------------------------------++-- This is for examples/README.md+withHeader :: BSL.ByteString -> (forall a . IsElfClass a => HeaderXX a -> b) -> Either String b+withHeader bs f =+ case decodeOrFail bs of+ Left (_, _, err) -> Left err+ Right (_, _, (classS :&: hxx) :: Header) -> Right $ withElfClass classS f hxx++printHeaderFile :: FilePath -> IO (Doc ())+printHeaderFile path = do+ bs <- fromStrict <$> BS.readFile path+ $eitherAddContext' $ withHeader bs printHeader++printHeadersFile :: FilePath -> IO (Doc ())+printHeadersFile path = do+ bs <- fromStrict <$> BS.readFile path+ (classS :&: HeadersXX (hdr, ss, ps)) <- parseHeaders bs+ return $ withSingI classS $ printHeaders hdr ss ps++printStrTableFile :: FilePath -> IO (Doc ())+printStrTableFile path = do+ bs <- readFileLazy path+ hdrs <- parseHeaders bs+ st <- getStringTable hdrs bs+ printStringTable st++printCopyStrTableFile :: FilePath -> IO (Doc ())+printCopyStrTableFile path = do+ bs <- readFileLazy path+ bs' <- copyElf bs+ hdrs <- parseHeaders bs'+ st <- getStringTable hdrs bs'+ printStringTable st++printRBuilderFile :: FilePath -> IO (Doc ())+printRBuilderFile path = do+ bs <- readFileLazy path+ hdrs <- parseHeaders bs+ printLayout hdrs bs++printCopyRBuilderFile :: FilePath -> IO (Doc ())+printCopyRBuilderFile path = do+ bs <- readFileLazy path+ bs' <- copyElf bs+ hdrs <- parseHeaders bs'+ printLayout hdrs bs'++printElfFile :: FilePath -> IO (Doc ())+printElfFile path = do+ bs <- readFileLazy path+ e <- parseElf bs+ printElf e++printCopyElfFile :: FilePath -> IO (Doc ())+printCopyElfFile path = do+ bs <- readFileLazy path+ bs' <- copyElf bs+ e <- parseElf bs'+ printElf e++-----------------------------------------------------------------------++testHeader64 :: Header+testHeader64 = SELFCLASS64 :&: HeaderXX ELFDATA2LSB 0 0 0 0 0 0 0 0 0 0 0 0 0++testHeader32 :: Header+testHeader32 = SELFCLASS32 :&: HeaderXX ELFDATA2MSB 0 0 0 0 0 0 0 0 0 0 0 0 0++testSection64 :: SectionXX 'ELFCLASS64+testSection64 = SectionXX 0 0 0 0 0 0 0 0 0 0++testSection32 :: SectionXX 'ELFCLASS32+testSection32 = SectionXX 0 0 0 0 0 0 0 0 0 0++testSegment64 :: SegmentXX 'ELFCLASS64+testSegment64 = SegmentXX 0 0 0 0 0 0 0 0++testSegment32 :: SegmentXX 'ELFCLASS32+testSegment32 = SegmentXX 0 0 0 0 0 0 0 0++testSymbolTableEntry64 :: SymbolXX 'ELFCLASS64+testSymbolTableEntry64 = SymbolXX 0 0 0 0 0 0++testSymbolTableEntry32 :: SymbolXX 'ELFCLASS32+testSymbolTableEntry32 = SymbolXX 0 0 0 0 0 0++mkSizeTest :: Binary a => String -> a -> Int64 -> TestTree+mkSizeTest name v s = testCase name (len @?= s)+ where+ len = BSL.length $ encode v++hdrSizeTests :: TestTree+hdrSizeTests = testGroup "header size" [ mkSizeTest "header 64" testHeader64 (headerSize ELFCLASS64)+ , mkSizeTest "header 32" testHeader32 (headerSize ELFCLASS32)++ , mkSizeTest "section 64" (Le testSection64) (sectionTableEntrySize ELFCLASS64)+ , mkSizeTest "section 32" (Be testSection32) (sectionTableEntrySize ELFCLASS32)++ , mkSizeTest "segment 64" (Le testSegment64) (segmentTableEntrySize ELFCLASS64)+ , mkSizeTest "segment 32" (Be testSegment32) (segmentTableEntrySize ELFCLASS32)++ , mkSizeTest "symbol table entry 64" (Le testSymbolTableEntry64) (symbolTableEntrySize ELFCLASS64)+ , mkSizeTest "symbol table entry 32" (Be testSymbolTableEntry32) (symbolTableEntrySize ELFCLASS32)+ ]++elfsForHeader :: [String]+elfsForHeader = [ "testdata/ppc/64/du", "testdata/arm_32_lsb/arp" ]++main :: IO ()+main = do++ elfs <- traverseDir "testdata" isElf++ defaultMain $ testGroup "elf" [ hdrSizeTests+ , testGroup "headers round trip" (mkTest <$> elfs)+ , testGroup "elf headers golden" (mkGoldenTest "elf_header" printHeaderFile <$> elfsForHeader)+ , testGroup "header golden" (mkGoldenTest "header" printHeadersFile <$> elfs)+ , testGroup "string table golden" (mkGoldenTest "strtable" printStrTableFile <$> elfs)+ , testGroup "layout golden" (mkGoldenTest "layout" printRBuilderFile <$> elfs)+ , testGroup "elf golden" (mkGoldenTest "elf" printElfFile <$> elfs)+ , testGroup "string table copy" (mkGoldenTestOSuffix "strtable" "copy" printCopyStrTableFile <$> elfs)+ , testGroup "layout copy" (mkGoldenTestOSuffix "layout" "copy" printCopyRBuilderFile <$> elfs)+ , testGroup "elf copy" (mkGoldenTestOSuffix "elf" "copy" printCopyElfFile <$> elfs)+ ]
+ tests/exceptions/Exceptions.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main (main) where++import Control.Exception.ChainedException++import Control.Exception hiding (try)+import Control.Monad.Catch+import Test.Tasty+import Test.Tasty.HUnit++--------------------------------------------++f :: IO ()+f = $chainedError "some error"++f' :: IO ()+f' = $chainedError'++data TestException = TestException deriving Show+instance Exception TestException++fe :: IO ()+fe = throwM TestException++f1 :: IO ()+f1 = $addContext "some context" f++f1' :: IO ()+f1' = $addContext' f++fe' :: IO ()+fe' = $addContext' fe++fe'e :: IO ()+fe'e = $addContext "some context 2" fe'++fmb :: IO ()+fmb = $maybeAddContext "some context 3" Nothing++fmb' :: IO ()+fmb' = $maybeAddContext' Nothing++fei' :: IO ()+fei' = $eitherAddContext' $ Left "some error description 4"++--------------------------------------------++checkExceptions :: IO () -> String -> IO ()+checkExceptions m s = try m >>= \ case+ Right _ -> assertFailure "it should throw an error"+ Left (e :: SomeException) -> show e @?= s++main :: IO ()+main = defaultMain $ testGroup "exceptions" [ testCase "f" $ checkExceptions f "some error (tests/exceptions/Exceptions.hs:17)"+ , testCase "f'" $ checkExceptions f' "(tests/exceptions/Exceptions.hs:20)"+ , testCase "fe" $ checkExceptions fe "TestException"+ , testCase "f1" $ checkExceptions f1 "some context (tests/exceptions/Exceptions.hs:29) // some error (tests/exceptions/Exceptions.hs:17)"+ , testCase "f1'" $ checkExceptions f1' "(tests/exceptions/Exceptions.hs:32) // some error (tests/exceptions/Exceptions.hs:17)"+ , testCase "fe'" $ checkExceptions fe' "(tests/exceptions/Exceptions.hs:35) // TestException"+ , testCase "fe'e" $ checkExceptions fe'e "some context 2 (tests/exceptions/Exceptions.hs:38) // (tests/exceptions/Exceptions.hs:35) // TestException"+ , testCase "fmb" $ checkExceptions fmb "some context 3 (tests/exceptions/Exceptions.hs:41)"+ , testCase "fmb'" $ checkExceptions fmb' "(tests/exceptions/Exceptions.hs:44)"+ , testCase "fei'" $ checkExceptions fei' "some error description 4 (tests/exceptions/Exceptions.hs:47)"+ ]