diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,4 @@ +1.0.0 +===== + +Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/hObjDump.hs b/app/hObjDump.hs new file mode 100644 --- /dev/null +++ b/app/hObjDump.hs @@ -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 diff --git a/app/hObjLayout.hs b/app/hObjLayout.hs new file mode 100644 --- /dev/null +++ b/app/hObjLayout.hs @@ -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 diff --git a/examples/AsmAarch64.hs b/examples/AsmAarch64.hs new file mode 100644 --- /dev/null +++ b/examples/AsmAarch64.hs @@ -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) diff --git a/examples/Examples.hs b/examples/Examples.hs new file mode 100644 --- /dev/null +++ b/examples/Examples.hs @@ -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 + ) diff --git a/examples/ForwardLabel.hs b/examples/ForwardLabel.hs new file mode 100644 --- /dev/null +++ b/examples/ForwardLabel.hs @@ -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 diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs new file mode 100644 --- /dev/null +++ b/examples/HelloWorld.hs @@ -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 diff --git a/examples/MkExe.hs b/examples/MkExe.hs new file mode 100644 --- /dev/null +++ b/examples/MkExe.hs @@ -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 ] diff --git a/examples/MkObj.hs b/examples/MkObj.hs new file mode 100644 --- /dev/null +++ b/examples/MkObj.hs @@ -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 + ] diff --git a/melf.cabal b/melf.cabal new file mode 100644 --- /dev/null +++ b/melf.cabal @@ -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 diff --git a/src/Control/Exception/ChainedException.hs b/src/Control/Exception/ChainedException.hs new file mode 100644 --- /dev/null +++ b/src/Control/Exception/ChainedException.hs @@ -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 |] diff --git a/src/Data/BList.hs b/src/Data/BList.hs new file mode 100644 --- /dev/null +++ b/src/Data/BList.hs @@ -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 diff --git a/src/Data/Elf.hs b/src/Data/Elf.hs new file mode 100644 --- /dev/null +++ b/src/Data/Elf.hs @@ -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 diff --git a/src/Data/Elf/Constants.hs b/src/Data/Elf/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Data/Elf/Constants.hs @@ -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 diff --git a/src/Data/Elf/Constants/Data.hs b/src/Data/Elf/Constants/Data.hs new file mode 100644 --- /dev/null +++ b/src/Data/Elf/Constants/Data.hs @@ -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) + + ]) diff --git a/src/Data/Elf/Constants/TH.hs b/src/Data/Elf/Constants/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Elf/Constants/TH.hs @@ -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 diff --git a/src/Data/Elf/Headers.hs b/src/Data/Elf/Headers.hs new file mode 100644 --- /dev/null +++ b/src/Data/Elf/Headers.hs @@ -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 diff --git a/src/Data/Elf/PrettyPrint.hs b/src/Data/Elf/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/Data/Elf/PrettyPrint.hs @@ -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)) diff --git a/src/Data/Endian.hs b/src/Data/Endian.hs new file mode 100644 --- /dev/null +++ b/src/Data/Endian.hs @@ -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 diff --git a/src/Data/Internal/Elf.hs b/src/Data/Internal/Elf.hs new file mode 100644 --- /dev/null +++ b/src/Data/Internal/Elf.hs @@ -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) diff --git a/src/Data/Interval.hs b/src/Data/Interval.hs new file mode 100644 --- /dev/null +++ b/src/Data/Interval.hs @@ -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 #-} diff --git a/tests/Golden.hs b/tests/Golden.hs new file mode 100644 --- /dev/null +++ b/tests/Golden.hs @@ -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) + ] diff --git a/tests/exceptions/Exceptions.hs b/tests/exceptions/Exceptions.hs new file mode 100644 --- /dev/null +++ b/tests/exceptions/Exceptions.hs @@ -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)" + ]