diff --git a/hurdle.cabal b/hurdle.cabal --- a/hurdle.cabal +++ b/hurdle.cabal @@ -1,5 +1,5 @@ name: hurdle -version: 0.3.0 +version: 0.4.0 license: BSD3 license-file: LICENSE copyright: Stephen Tetley @@ -26,6 +26,10 @@ . Change-log . + 0.3.0 to 0.4.0 + . + * Changed to use kangaroo-0.4.0 + . 0.2.0 to 0.3.0 . * Changes to use kangaroo-0.2.0 @@ -45,13 +49,15 @@ Build-Depends: base < 5, array >= 0.2.0.0 && < 0.4, containers, - kangaroo >= 0.2.0 && < 0.3 + kangaroo >= 0.4.0 && < 0.5, + bytestring Main-Is: Hurdle.hs Hs-Source-Dirs: src Other-Modules: Hurdle.Ar.Datatypes, Hurdle.Ar.Parser, Hurdle.Ar.TextDump, + Hurdle.Base.Table, Hurdle.Base.Utils, Hurdle.Coff.Datatypes, Hurdle.Coff.DefOutput, diff --git a/src/Hurdle/Ar/Datatypes.hs b/src/Hurdle/Ar/Datatypes.hs --- a/src/Hurdle/Ar/Datatypes.hs +++ b/src/Hurdle/Ar/Datatypes.hs @@ -16,8 +16,6 @@ module Hurdle.Ar.Datatypes where -import qualified Data.ByteString as BSW8 -import Data.Word data ArArchive = ArArchive { ar_magic :: String @@ -28,7 +26,7 @@ data ArchiveObject = ArchiveObject { ar_header :: ArHeader - , ar_body :: [Word8] -- needs thought... shouldn't be a list + , ar_body :: (Int,Int) } data ArHeader = ArHeader diff --git a/src/Hurdle/Ar/Parser.hs b/src/Hurdle/Ar/Parser.hs --- a/src/Hurdle/Ar/Parser.hs +++ b/src/Hurdle/Ar/Parser.hs @@ -56,16 +56,17 @@ header <- arHeader let sz = arh_size header liftIOAction $ putStrLn ("size " ++ show sz) - body <- count sz word8 pos <- position - when (pos `mod` 2 /= 0) (char >> return ()) -- should be a newline + body <- count sz word8 + end_pos <- position + when (end_pos `mod` 2 /= 0) (anyChar >> return ()) -- should be a newline return $ ArchiveObject { ar_header = header - , ar_body = body + , ar_body = (pos,sz) } paddedNumber :: (Read a, Integral a) => Int -> Parser a -paddedNumber i = liftM fn $ count i char +paddedNumber i = liftM fn $ count i anyChar where fn = read . takeWhile isDigit diff --git a/src/Hurdle/Ar/TextDump.hs b/src/Hurdle/Ar/TextDump.hs --- a/src/Hurdle/Ar/TextDump.hs +++ b/src/Hurdle/Ar/TextDump.hs @@ -16,11 +16,10 @@ module Hurdle.Ar.TextDump where -import Hurdle.Base.Utils ( applyfs ) +import Hurdle.Base.Table import Hurdle.Ar.Datatypes import Data.Char -import Numeric import Text.PrettyPrint.JoinPrint hiding ( length ) @@ -29,33 +28,31 @@ printArchive = putStr . archiveText archiveText :: ArArchive -> String -archiveText = render . ppArchive - -ppArchive :: ArArchive -> Doc -ppArchive a = - text (ar_magic a) - <%> (vcat $ map ppArchiveObject $ ar_objects a) +archiveText = show . ppArchive +ppArchive :: ArArchive -> VDoc +ppArchive a = vconcat $ + [ vdoc $ text $ ar_magic a + , vconcat $ map ppArchiveObject $ ar_objects a + ] -ppArchiveObject :: ArchiveObject -> Doc +ppArchiveObject :: ArchiveObject -> VDoc ppArchiveObject = ppArHeader . ar_header -ppArHeader :: ArHeader -> Doc -ppArHeader a = - tableProlog "Header" (24,6) (applyfs fields a) +ppArHeader :: ArHeader -> VDoc +ppArHeader = mkTable "Header" . vcat . sequence fields where - ppf = ppField 4 24 fields = - [ ppf 16 "name" (text . arh_name) - , ppf 12 "date" (text . arh_date) - , ppf 6 "user id" (int . arh_user_id) - , ppf 6 "group id" (int . arh_group_id) - , ppf 8 "mode" (text . arh_mode) - , ppf 10 "size" (int . arh_size) - , ppf 2 "trailer" (tup2 . arh_trailer) + [ recRow 16 "name" . text . arh_name + , recRow 12 "date" . text . arh_date + , recRow 6 "user id" . int . arh_user_id + , recRow 6 "group id" . int . arh_group_id + , recRow 8 "mode" . text . arh_mode + , recRow 10 "size" . int . arh_size + , recRow 2 "trailer" . tup2 . arh_trailer ] - tup2 (x:y:xs) = ppHex 2 (ord x) <+> ppHex 2 (ord y) <+> text xs + tup2 (x:y:xs) = oxhex 2 (ord x) <+> oxhex 2 (ord y) <+> text xs tup2 xs = text xs @@ -64,37 +61,37 @@ -------------------------------------------------------------------------------- -- Helpers -tableProlog :: String -> (Int,Int) -> [Doc] -> Doc -tableProlog s (m,n) ds = - columnSep - <%> text s - <%> columnSep - <%> columnHeadings m n - <%> columnSep - <%> vcat ds - where - columnHeadings fsz vsz = - text "size" <+> text (pad fsz ' ' "field") <+> text (pad vsz ' ' "value") +-- 4r-24r-24l +colHeadings :: VDoc +colHeadings = vdoc $ row3 (text "size") (text "field") (text "value") -columnSep :: Doc -columnSep = text $ replicate 60 '-' +row3 :: Doc -> Doc -> Doc -> Doc +row3 = row dblspace (alignRight 4 $ alignRight 24 $ alignLeft 24 $ endrow) +recRow :: Int -> String -> Doc -> Doc +recRow fsize name doc = row3 (int fsize) (text name) doc -ppField :: Int -> Int -> Int -> String -> (a -> Doc) -> a -> Doc -ppField n1 n2 sz field_name f a = text sz' <+> text field_name' <+> f a +type TableName = String + +mkTable :: TableName -> VDoc -> VDoc +mkTable tname rows = title `vcons` (block1 `vappend` rows) where - sz' = pad n1 ' ' (show sz) - field_name' = pad n2 ' ' field_name + title = text tname + block1 = vconcat [rowSep, colHeadings, rowSep] -ppHex :: Integral a => Int -> a -> Doc -ppHex n i = text "0x" <> (text $ pad n '0' $ showHex i "") - -pad :: Int -> Char -> String -> String -pad n ch s | length s < n = replicate (n - length s) ch ++ s - | otherwise = s +rowSep :: VDoc +rowSep = vdoc $ replicateChar 60 '-' -listDoc :: [Doc] -> Doc -listDoc = brackets . punctuate comma + +-- TO ADD TO JoinPrint +list :: [Doc] -> Doc +list = brackets . punctuate comma + +vdoc :: Doc -> VDoc +vdoc = vcat . return + +vappend :: VDoc -> VDoc -> VDoc +vappend a b = vconcat [a,b] diff --git a/src/Hurdle/Base/Table.hs b/src/Hurdle/Base/Table.hs new file mode 100644 --- /dev/null +++ b/src/Hurdle/Base/Table.hs @@ -0,0 +1,98 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Hurdle.Base.Table +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : to be determined. +-- +-- Table formatting +-- +-------------------------------------------------------------------------------- + +module Hurdle.Base.Table + ( + FieldWidth + , Rowf + , row + , endrow + , alignLeft + , alignRight + , alignCenter + + ) where + + +import Text.PrettyPrint.JoinPrint -- package: kangaroo + +import Prelude hiding ( length, null ) + +data Align = ALeft | ACenter | ARight + deriving (Eq,Ord,Show) + +type FieldWidth = Int + +type FieldProp = (FieldWidth,Align) + +-- Little trick to avoided prefixing with the sep +type Sep = Either Doc Doc + +-- Essentially the 'typecase' printf... +-- Note an extra arg is threaded fr the separator + + + +newtype Rowf t = Rowf { rowfApp :: Sep -> Doc -> t } + +field :: FieldProp -> Rowf t -> Rowf (Doc -> t) +field prop k = Rowf $ \rator acc d -> case rator of + Left sep -> rowfApp k (Right sep) (format1 prop d) + Right sep -> rowfApp k (Right sep) (acc <> sep <> (format1 prop d)) + + +endrow :: Rowf Doc +endrow = Rowf $ \_ acc -> acc + + +row :: Doc -> Rowf t -> t +row sep p = (rowfApp p) (Left sep) empty + + +alignLeft :: FieldWidth -> Rowf t -> Rowf (Doc -> t) +alignLeft w = field (w,ALeft) + +alignRight :: FieldWidth -> Rowf t -> Rowf (Doc -> t) +alignRight w = field (w,ARight) + +alignCenter :: FieldWidth -> Rowf t -> Rowf (Doc -> t) +alignCenter w = field (w,ACenter) + + + +format1 :: FieldProp -> Doc -> Doc +format1 (w,align) d = step (length d) where + step dw | dw > w = truncateTo w align d + | dw < w = padTo w align d + | otherwise = d + +-- Note truncate with Center alignment truncates the right side +truncateTo :: Int -> Align -> Doc -> Doc +truncateTo w ALeft d = truncr w d +truncateTo w _ d = truncl w d + +-- truncateTo w ACenter d = let (a,b) = splitTwo w in truncl b $ truncr a d + +padTo :: Int -> Align -> Doc -> Doc +padTo w ALeft d = padr w ' ' d +padTo w ACenter d = let (a,b) = splitTwo w in padl b ' ' $ padr a ' ' d +padTo w ARight d = padl w ' ' d + +splitTwo :: Int -> (Int,Int) +splitTwo n | even n = let h = n `div` 2 in (h,h) + | otherwise = let h = n `div` 2 in (h+1,h) + + diff --git a/src/Hurdle/Coff/Parser.hs b/src/Hurdle/Coff/Parser.hs --- a/src/Hurdle/Coff/Parser.hs +++ b/src/Hurdle/Coff/Parser.hs @@ -135,7 +135,7 @@ pecoffSignature :: Parser (Char,Char,Char,Char) -pecoffSignature = liftM4 (,,,) char char char char +pecoffSignature = liftM4 (,,,) anyChar anyChar anyChar anyChar @@ -259,7 +259,7 @@ sectionHeader :: Parser SectionHeader sectionHeader = do - name <- liftM stringTruncate (count 8 char) + name <- liftM stringTruncate (count 8 anyChar) -- this should be a combinator virtual_size <- word32le diff --git a/src/Hurdle/Coff/TextDump.hs b/src/Hurdle/Coff/TextDump.hs --- a/src/Hurdle/Coff/TextDump.hs +++ b/src/Hurdle/Coff/TextDump.hs @@ -16,12 +16,11 @@ module Hurdle.Coff.TextDump where -import Hurdle.Base.Utils ( applyfs ) +import Hurdle.Base.Table import Hurdle.Coff.Datatypes import qualified Data.Map as Map import Data.Word -import Numeric import Text.PrettyPrint.JoinPrint hiding ( length ) @@ -30,80 +29,77 @@ printImage = putStr . imageText imageText :: Image -> String -imageText = render . ppImage +imageText = show . ppImage printCOFF :: COFFHeader -> IO () printCOFF = putStr . coff coff :: COFFHeader -> String -coff = render . ppCOFFHeader - -ppImage :: Image -> Doc -ppImage a = - ppDOSHeader (image_dos_header a) - <%> columnSep - <%> ppSignature (image_signature a) - <%> ppCOFFHeader (image_coff_header a) - <%> ppImageOptionalHeader (image_opt_header a) - <%> (vcat $ map ppSectionHeader $ Map.elems $ image_section_headers a) - <%> maybe empty ppExportData (image_export_data a) +coff = show . ppCOFFHeader +ppImage :: Image -> VDoc +ppImage a = vconcat $ + [ ppDOSHeader (image_dos_header a) + , rowSep + , vdoc $ ppSignature (image_signature a) + , ppCOFFHeader (image_coff_header a) + , ppImageOptionalHeader (image_opt_header a) + , (vconcat $ map ppSectionHeader $ Map.elems $ image_section_headers a) + , maybe (vdoc empty) ppExportData (image_export_data a) + ] -ppDOSHeader :: DOSHeader -> Doc -ppDOSHeader a = - tableProlog "IMAGE_DOS_HEADER" (24,6) (applyfs fields a) +ppDOSHeader :: DOSHeader -> VDoc +ppDOSHeader = mkTable "IMAGE_DOS_HEADER" . vcat . sequence fields where - ppf = ppField 4 24 fields = - [ ppf 2 "magic" (ppHex 4 . dh_magic_number) - , ppf 2 "bytes last page" (ppHex 4 . dh_bytes_on_last_page) - , ppf 2 "pages in file" (ppHex 4 . dh_pages_in_file) - , ppf 2 "relocations" (ppHex 4 . dh_relocations) - , ppf 2 "header para size" (ppHex 4 . dh_header_paras_size) - , ppf 2 "min extra paragraphs" (ppHex 4 . dh_min_extra_paras) - , ppf 2 "max extra paragraphs" (ppHex 4 . dh_max_extra_paras) - , ppf 2 "initial SS value" (ppHex 4 . dh_initial_relative_ss) - , ppf 2 "initial SP value" (ppHex 4 . dh_initial_sp) - , ppf 2 "checksum" (ppHex 4 . dh_header_checksum) + [ recRow 2 "magic" . oxhex4 . dh_magic_number + , recRow 2 "bytes last page" . oxhex4 . dh_bytes_on_last_page + , recRow 2 "pages in file" . oxhex4 . dh_pages_in_file + , recRow 2 "relocations" . oxhex4 . dh_relocations + , recRow 2 "header para size" . oxhex4 . dh_header_paras_size + , recRow 2 "min extra paragraphs" . oxhex4 . dh_min_extra_paras + , recRow 2 "max extra paragraphs" . oxhex4 . dh_max_extra_paras + , recRow 2 "initial SS value" . oxhex4 . dh_initial_relative_ss + , recRow 2 "initial SP value" . oxhex4 . dh_initial_sp + , recRow 2 "checksum" . oxhex4 . dh_header_checksum - , ppf 2 "initial IP value" (ppHex 4 . dh_initial_ip) - , ppf 2 "initial CS value" (ppHex 4 . dh_initial_relative_cs) - , ppf 2 "relocation table addr" (ppHex 4 . dh_reltable_file_addr) - , ppf 2 "overlay number" (ppHex 4 . dh_overlay_number) - , ppf 8 "reserved 1" (tup4 . dh_reserved_words) - , ppf 2 "oem identifier" (ppHex 4 . dh_oem_identifier) - , ppf 2 "oem info" (ppHex 4 . dh_oem_info) - , ppf 20 "reserved 2" (text . show . dh_reserved_words_two) - , ppf 4 "new exe header addr" (ppHex 8 . dh_new_exe_addr) - ] + , recRow 2 "initial IP value" . oxhex4 . dh_initial_ip + , recRow 2 "initial CS value" . oxhex4 . dh_initial_relative_cs + , recRow 2 "relocation table addr" . oxhex4 . dh_reltable_file_addr + , recRow 2 "overlay number" . oxhex4 . dh_overlay_number + , recRow 8 "reserved 1" . tup4 . dh_reserved_words + , recRow 2 "oem identifier" . oxhex4 . dh_oem_identifier + , recRow 2 "oem info" . oxhex4 . dh_oem_info + , recRow 20 "reserved 2" . text . show . dh_reserved_words_two + , recRow 4 "new exe header addr" . oxhex8 . dh_new_exe_addr + ] tup4 (s,t,u,v) = text $ show [s,t,u,v] ppSignature :: (Char,Char,Char,Char) -> Doc ppSignature (s,t,u,v) = - text "Signature:" <+> (listDoc $ map (text . show) [s,t,u,v]) + text "Signature:" <+> (list $ map (text . show) [s,t,u,v]) -ppCOFFHeader :: COFFHeader -> Doc -ppCOFFHeader a = - tableProlog "COFF HEADER" (24,6) (applyfs fields a) +ppCOFFHeader :: COFFHeader -> VDoc +ppCOFFHeader = mkTable "COFF HEADER" . vcat . sequence fields where - ppf = ppField 4 24 fields = - [ ppf 2 "machine" (ppHex 4 . ch_machine) - , ppf 2 "num sections" (ppHex 4 . ch_num_sections) - , ppf 4 "timedatestamp" (ppHex 8 . ch_timedate_stamp) - , ppf 4 "ptr to sym table" (ppHex 8 . ch_sym_table_ptr) - , ppf 4 "num symbols" (ppHex 8 . ch_num_symbols) - , ppf 2 "size optional header" (ppHex 4 . ch_opt_header_size) - , ppf 2 "characteristics" (ppHex 4 . ch_characteristics) + [ recRow 2 "machine" . oxhex4 . ch_machine + , recRow 2 "num sections" . oxhex4 . ch_num_sections + , recRow 4 "timedatestamp" . oxhex8 . ch_timedate_stamp + , recRow 4 "ptr to sym table" . oxhex8 . ch_sym_table_ptr + , recRow 4 "num symbols" . oxhex8 . ch_num_symbols + , recRow 2 "size optional header" . oxhex4 . ch_opt_header_size + , recRow 2 "characteristics" . oxhex4 . ch_characteristics ] -ppImageOptionalHeader :: ImageOptionalHeader -> Doc -ppImageOptionalHeader a = - ppOptionalStandardHeader (ioh_header_std_fields a) - <%> ppOptionalWindowsHeader (ioh_nt_specific_fields a) - <%> (vcat $ zipWith ppHeaderDataDirectory names (ioh_data_directory a)) +ppImageOptionalHeader :: ImageOptionalHeader -> VDoc +ppImageOptionalHeader a = vconcat $ + [ ppOptionalStandardHeader $ ioh_header_std_fields a + , ppOptionalWindowsHeader $ ioh_nt_specific_fields a + , vconcat $ zipWith ppHeaderDataDirectory names $ ioh_data_directory a + ] where names = [ ".edata" , ".idata" @@ -123,175 +119,165 @@ , "reserved" ] -ppOptionalStandardHeader :: OptionalStandardHeader -> Doc -ppOptionalStandardHeader a = - tableProlog "IMAGE OPTIONAL HEADER STANDARD" (24,6) (applyfs fields a) +ppOptionalStandardHeader :: OptionalStandardHeader -> VDoc +ppOptionalStandardHeader = + mkTable "IMAGE OPTIONAL HEADER STANDARD" . vcat . sequence fields where - ppf = ppField 4 24 fields = - [ ppf 2 "magic" (ppHex 4 . osh_magic) - , ppf 1 "major linker ver." (ppHex 2 . osh_major_linker_version) - , ppf 1 "minor linker ver." (ppHex 2 . osh_minor_linker_version) - , ppf 4 "size of code" (ppHex 8 . osh_size_of_code) - , ppf 4 "size of init. data" (ppHex 8 . osh_size_of_inited_data) - , ppf 4 "size of uninit. data" (ppHex 8 . osh_size_of_uninited_data) - , ppf 4 "entry ptr addr" (ppHex 8 . osh_entry_point_addr) - , ppf 4 "base of code" (ppHex 8 . osh_base_of_code) - , ppf 4 "base of data" (ppHex 8 . osh_base_of_data) + [ recRow 2 "magic" . oxhex4 . osh_magic + , recRow 1 "major linker ver." . oxhex2 . osh_major_linker_version + , recRow 1 "minor linker ver." . oxhex2 . osh_minor_linker_version + , recRow 4 "size of code" . oxhex8 . osh_size_of_code + , recRow 4 "size of init. data" . oxhex8 . osh_size_of_inited_data + , recRow 4 "size of uninit. data" . oxhex8 . osh_size_of_uninited_data + , recRow 4 "entry ptr addr" . oxhex8 . osh_entry_point_addr + , recRow 4 "base of code" . oxhex8 . osh_base_of_code + , recRow 4 "base of data" . oxhex8 . osh_base_of_data ] -ppOptionalWindowsHeader :: OptionalWindowsHeader -> Doc -ppOptionalWindowsHeader a = - tableProlog "IMAGE OPTIONAL HEADER NT SPECIFIC" (24,6) (applyfs fields a) +ppOptionalWindowsHeader :: OptionalWindowsHeader -> VDoc +ppOptionalWindowsHeader = + mkTable "IMAGE OPTIONAL HEADER NT SPECIFIC" . vcat . sequence fields where - ppf = ppField 4 24 fields = - [ ppf 4 "image base" (ppHex 8 . owh_image_base) - , ppf 4 "section alignment" (ppHex 8 . owh_section_alignment) - , ppf 4 "file alignment" (ppHex 8 . owh_file_alignment) - , ppf 2 "major os version" (ppHex 4 . owh_major_os_version) - , ppf 2 "minor os version" (ppHex 4 . owh_minor_os_version) - , ppf 2 "major image version" (ppHex 4 . owh_major_image_version) - , ppf 2 "minor image version" (ppHex 4 . owh_minor_image_version) - , ppf 2 "major subsys version" (ppHex 4 . owh_major_subsys_version) - , ppf 2 "minor subsys version" (ppHex 4 . owh_minor_subsys_version) - , ppf 4 "win32 version" (ppHex 8 . owh_win32_version) - , ppf 4 "size of image" (ppHex 8 . owh_size_of_image) - , ppf 4 "size of headers" (ppHex 8 . owh_size_of_headers) - , ppf 4 "checksum" (ppHex 8 . owh_checksum) - , ppf 2 "subsystem" (ppHex 4 . owh_subsystem) - , ppf 2 "dll characteristics" (ppHex 4 . owh_dll_characteristics) - , ppf 4 "size of stack reserve" (ppHex 8 . owh_size_stack_reserve) - , ppf 4 "size of stack commit" (ppHex 8 . owh_size_stack_commit) - , ppf 4 "size of heap reserve" (ppHex 8 . owh_size_heap_reserve) - , ppf 4 "size of heap commit" (ppHex 8 . owh_size_heap_commit) - , ppf 4 "loader flags" (ppHex 8 . owh_loader_flags) - , ppf 4 "rva num and sizes" (ppHex 8 . owh_rva_num_and_sizes) + [ recRow 4 "image base" . oxhex8 . owh_image_base + , recRow 4 "section alignment" . oxhex8 . owh_section_alignment + , recRow 4 "file alignment" . oxhex8 . owh_file_alignment + , recRow 2 "major os version" . oxhex4 . owh_major_os_version + , recRow 2 "minor os version" . oxhex4 . owh_minor_os_version + , recRow 2 "major image version" . oxhex4 . owh_major_image_version + , recRow 2 "minor image version" . oxhex4 . owh_minor_image_version + , recRow 2 "major subsys version" . oxhex4 . owh_major_subsys_version + , recRow 2 "minor subsys version" . oxhex4 . owh_minor_subsys_version + , recRow 4 "win32 version" . oxhex8 . owh_win32_version + , recRow 4 "size of image" . oxhex8 . owh_size_of_image + , recRow 4 "size of headers" . oxhex8 . owh_size_of_headers + , recRow 4 "checksum" . oxhex8 . owh_checksum + , recRow 2 "subsystem" . oxhex4 . owh_subsystem + , recRow 2 "dll characteristics" . oxhex4 . owh_dll_characteristics + , recRow 4 "size of stack reserve" . oxhex8 . owh_size_stack_reserve + , recRow 4 "size of stack commit" . oxhex8 . owh_size_stack_commit + , recRow 4 "size of heap reserve" . oxhex8 . owh_size_heap_reserve + , recRow 4 "size of heap commit" . oxhex8 . owh_size_heap_commit + , recRow 4 "loader flags" . oxhex8 . owh_loader_flags + , recRow 4 "rva num and sizes" . oxhex8 . owh_rva_num_and_sizes ] -ppHeaderDataDirectory :: String -> HeaderDataDirectory -> Doc -ppHeaderDataDirectory s a = - tableProlog s (24,6) (applyfs fields a) +ppHeaderDataDirectory :: String -> HeaderDataDirectory -> VDoc +ppHeaderDataDirectory name = mkTable name . vcat . sequence fields where - ppf = ppField 4 24 fields = - [ ppf 4 "virtual address" (ppHex 8 . hdd_virtual_addr) - , ppf 4 "size" (ppHex 8 . hdd_size) - ] + [ recRow 4 "virtual address" . oxhex8 . hdd_virtual_addr + , recRow 4 "size" . oxhex8 . hdd_size + ] -ppSectionHeader :: SectionHeader -> Doc -ppSectionHeader a = - tableProlog "SECTION HEADER" (24,6) (applyfs fields a) +ppSectionHeader :: SectionHeader -> VDoc +ppSectionHeader = mkTable "SECTION HEADER" . vcat . sequence fields where - ppf = ppField 4 24 fields = - [ ppf 8 "name" (text . sh_name) - , ppf 4 "virtual size" (ppHex 8 . sh_virtual_size) - , ppf 4 "virtual addr" (ppHex 8 . sh_virtual_addr) - , ppf 4 "size of raw data" (ppHex 8 . sh_size_raw_data) - , ppf 4 "ptr to raw data" (ppHex 8 . sh_ptr_raw_data) - , ppf 4 "ptr to relocations" (ppHex 8 . sh_ptr_relocations) - , ppf 4 "ptr to line numbers" (ppHex 8 . sh_ptr_linenums) - , ppf 2 "num of relocations" (ppHex 4 . sh_num_relocations) - , ppf 2 "num of line numbers" (ppHex 4 . sh_num_linenums) - , ppf 4 "characteristics" (ppHex 8 . sh_characteristics) - ] + [ recRow 8 "name" . text . sh_name + , recRow 4 "virtual size" . oxhex8 . sh_virtual_size + , recRow 4 "virtual addr" . oxhex8 . sh_virtual_addr + , recRow 4 "size of raw data" . oxhex8 . sh_size_raw_data + , recRow 4 "ptr to raw data" . oxhex8 . sh_ptr_raw_data + , recRow 4 "ptr to relocations" . oxhex8 . sh_ptr_relocations + , recRow 4 "ptr to line numbers" . oxhex8 . sh_ptr_linenums + , recRow 2 "num of relocations" . oxhex4 . sh_num_relocations + , recRow 2 "num of line numbers" . oxhex4 . sh_num_linenums + , recRow 4 "characteristics" . oxhex8 . sh_characteristics + ] -ppExportData :: ExportData -> Doc -ppExportData a = - ppExportDirectoryTable (ed_directory_table a) - <%> ppExportAddressTable (ed_export_address_table a) - <%> ppExportNamePtrTable (ed_name_ptr_table a) - <%> ppExportOrdinalTable (ed_ordinal_table a) - <%> ppExportNames (ed_name_table a) +ppExportData :: ExportData -> VDoc +ppExportData = vconcat . sequence tables + where + tables = + [ ppExportDirectoryTable . ed_directory_table + , ppExportAddressTable . ed_export_address_table + , ppExportNamePtrTable . ed_name_ptr_table + , ppExportOrdinalTable . ed_ordinal_table + , ppExportNames . ed_name_table + ] -ppExportDirectoryTable :: ExportDirectoryTable -> Doc -ppExportDirectoryTable a = - tableProlog ".edata (Export directory table)" (24,6) (applyfs fields a) +ppExportDirectoryTable :: ExportDirectoryTable -> VDoc +ppExportDirectoryTable = + mkTable ".edata (Export directory table)" . vcat . sequence fields where - ppf = ppField 4 24 fields = - [ ppf 8 "export flags" (ppHex 8 . edt_export_flags) - , ppf 8 "timedate stamp" (ppHex 8 . edt_timedate_stamp) - , ppf 4 "major version" (ppHex 4 . edt_major_version) - , ppf 4 "minor version" (ppHex 4 . edt_minor_version) - , ppf 8 "name rva" (ppHex 8 . edt_name_rva) - , ppf 8 "oridinal base" (ppHex 8 . edt_ordinal_base) - , ppf 8 "addr table entries" (ppHex 8 . edt_num_addr_table_entries) - , ppf 8 "num name ptrs" (ppHex 8 . edt_num_name_ptrs) - , ppf 8 "export addr table rva" (ppHex 8 . edt_export_addr_table_rva) - , ppf 8 "name ptr rva" (ppHex 8 . edt_name_ptr_table_rva) - , ppf 8 "ordinal table rva" (ppHex 8 . edt_ordinal_table_rva) - ] + [ recRow 8 "export flags" . oxhex8 . edt_export_flags + , recRow 8 "timedate stamp" . oxhex8 . edt_timedate_stamp + , recRow 4 "major version" . oxhex4 . edt_major_version + , recRow 4 "minor version" . oxhex4 . edt_minor_version + , recRow 8 "name rva" . oxhex8 . edt_name_rva + , recRow 8 "oridinal base" . oxhex8 . edt_ordinal_base + , recRow 8 "addr table entries" . oxhex8 . edt_num_addr_table_entries + , recRow 8 "num name ptrs" . oxhex8 . edt_num_name_ptrs + , recRow 8 "export addr table rva" . oxhex8 . edt_export_addr_table_rva + , recRow 8 "name ptr rva" . oxhex8 . edt_name_ptr_table_rva + , recRow 8 "ordinal table rva" . oxhex8 . edt_ordinal_table_rva + ] -ppExportAddressTable :: ExportAddressTable -> Doc -ppExportAddressTable a = - tableProlog "Export address" (24,6) (map field $ getExportAddressTable a) + + +ppExportAddressTable :: ExportAddressTable -> VDoc +ppExportAddressTable = + mkTable "Export address" . vcat . map mkRow . getExportAddressTable where - ppf = ppField 4 24 - field (EA_Export_RVA w32) = ppf 8 "export RVA" (ppHex 8) w32 - field (EA_Forwarder_RVA w32) = ppf 8 "forwarder RVA" (ppHex 8) w32 + mkRow (EA_Export_RVA n) = row3 (int 8) (text "export RVA") (oxhex8 n) + mkRow (EA_Forwarder_RVA n) = row3 (int 8) (text "forwarder RVA") (oxhex8 n) -ppExportNamePtrTable :: [Word32] -> Doc -ppExportNamePtrTable a = - tableProlog "Export name pointers" (24,6) (map field a) +ppExportNamePtrTable :: [Word32] -> VDoc +ppExportNamePtrTable xs = mkTable "Export name pointers" $ vcat $ map mkRow xs where - ppf = ppField 4 24 - field = ppf 8 "name ptr" (ppHex 8) + mkRow = row3 (int 8) (text "name ptr") . oxhex8 -ppExportOrdinalTable :: [Word16] -> Doc -ppExportOrdinalTable a = - tableProlog "Export ordinals" (24,6) (map field a) +ppExportOrdinalTable :: [Word16] -> VDoc +ppExportOrdinalTable xs = mkTable "Export ordinals" $ vcat $ map mkRow xs where - ppf = ppField 4 24 - field = ppf 4 "ordinal" (ppHex 4) + mkRow = row3 (int 4) (text "ordinal") . oxhex4 -ppExportNames :: [String] -> Doc -ppExportNames a = - tableProlog "Export names" (24,6) (map field a) +ppExportNames :: [String] -> VDoc +ppExportNames xs = mkTable "Export names" $ vcat $ map mkRow xs where - ppf = ppField 4 24 - field = ppf 4 "export name" text + mkRow = row3 (text "-") (text "export name") . text -------------------------------------------------------------------------------- -- Helpers -tableProlog :: String -> (Int,Int) -> [Doc] -> Doc -tableProlog s (m,n) ds = - columnSep - <%> text s - <%> columnSep - <%> columnHeadings m n - <%> columnSep - <%> vcat ds - where - columnHeadings fsz vsz = - text "size" <+> text (pad fsz ' ' "field") <+> text (pad vsz ' ' "value") +-- 4r-24r-24l +colHeadings :: VDoc +colHeadings = vdoc $ row3 (text "size") (text "field") (text "value") -columnSep :: Doc -columnSep = text $ replicate 60 '-' +row3 :: Doc -> Doc -> Doc -> Doc +row3 = row dblspace (alignRight 4 $ alignRight 24 $ alignLeft 24 $ endrow) +recRow :: Int -> String -> Doc -> Doc +recRow fsize name doc = row3 (int fsize) (text name) doc -ppField :: Int -> Int -> Int -> String -> (a -> Doc) -> a -> Doc -ppField n1 n2 sz field_name f a = text sz' <+> text field_name' <+> f a +type TableName = String + +mkTable :: TableName -> VDoc -> VDoc +mkTable tname rows = title `vcons` (block1 `vappend` rows) where - sz' = pad n1 ' ' (show sz) - field_name' = pad n2 ' ' field_name + title = text tname + block1 = vconcat [rowSep, colHeadings, rowSep] -ppHex :: Integral a => Int -> a -> Doc -ppHex n i = text "0x" <> (text $ pad n '0' $ showHex i "") - -pad :: Int -> Char -> String -> String -pad n ch s | length s < n = replicate (n - length s) ch ++ s - | otherwise = s +rowSep :: VDoc +rowSep = vdoc $ replicateChar 60 '-' -listDoc :: [Doc] -> Doc -listDoc = brackets . punctuate comma +-- TO ADD TO JoinPrint +list :: [Doc] -> Doc +list = brackets . punctuate comma + +vdoc :: Doc -> VDoc +vdoc = vcat . return + +vappend :: VDoc -> VDoc -> VDoc +vappend a b = vconcat [a,b]