simple-tar (empty) → 0.5
raw patch · 4 files changed
+400/−0 lines, 4 filesdep +basedep +bytestringdep +cerealsetup-changed
Dependencies added: base, bytestring, cereal, containers, filepath, time
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- simple-tar.cabal +32/−0
- src/Codec/Archive/Tar.hs +336/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Adam Wick++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Adam Wick nor the names of other+ 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+OWNER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ simple-tar.cabal view
@@ -0,0 +1,32 @@+name: simple-tar+version: 0.5+license: BSD3+license-file: LICENSE+author: Adam Wick <awick@galois.com>+maintainer: Adam Wick <awick@galois.com>+bug-reports: https://github.com/GaloisInc/simple-tar/issues+copyright: 2016 Galois, Inc+category: Codec+synopsis: Simple, pure, file-system-free reading of tar files+description: This library is for reading \"@.tar@\" files found from+ some other source, and providing a mechanism for accessing+ their files. It specifically supports the USTAR tar format;+ other formats may come in the future by request.+build-type: Simple+cabal-version: >= 1.8+tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.1++source-repository head+ type: git+ location: https://github.com/GaloisInc/simple-tar++library+ hs-source-dirs: src+ build-depends: base >= 4.7 && < 5.0,+ bytestring >= 0.10.4 && < 0.14,+ cereal >= 0.5.2 && < 0.7,+ containers >= 0.5.5 && < 0.9,+ filepath >= 1.3 && < 1.7,+ time >= 1.4.2 && < 1.7+ exposed-modules: Codec.Archive.Tar+ ghc-options: -Wall
+ src/Codec/Archive/Tar.hs view
@@ -0,0 +1,336 @@+{-# LANGUAGE RecordWildCards #-}+module Codec.Archive.Tar(+ Archive+ , ArchiveHeader(..)+ , ArchiveMember(..)+ , RegularFile(..)+ , Link(..)+ , Device(..)+ , SpecialFIFOFile(..)+ , unarchive+ )+ where++import Control.Monad(unless)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import Data.Char(digitToInt)+import Data.Map.Strict(Map)+import qualified Data.Map.Strict as Map+import Data.Serialize.Get+import Data.String(IsString(..))+import Data.Time.Clock(UTCTime(..))+import Data.Time.Clock.POSIX(posixSecondsToUTCTime)+import Data.Time.LocalTime()+import Data.ByteString(ByteString)+import Data.Word(Word)++type Archive = Map FilePath ArchiveMember++data ArchiveMember = RegularFileMember RegularFile+ | LinkMember Link+ | SymbolicLinkMember Link+ | CharacterDeviceMember Device+ | BlockDeviceMember Device+ | DirectoryMember Directory+ | SpecialFIFOFileMember SpecialFIFOFile+ | ReservedMember RegularFile+ | CustomMember Char ArchiveHeader ByteString+ deriving (Show)++unarchive :: ByteString -> Either String Archive+unarchive = runGet getMembers++data ArchiveHeader = ArchiveHeader+ { hdrFileName :: FilePath+ , hdrMode :: Word+ , hdrOwner :: Word+ , hdrGroup :: Word+ , hdrSize :: Word+ , hdrModificationTime :: UTCTime+ , hdrChecksum :: Word+ , hdrTypeFlag :: RecordTypeFlag+ , hdrLinkName :: FilePath+ , hdrMagic :: String+ , hdrVersion :: ByteString+ , hdrUserName :: String+ , hdrGroupName :: String+ , hdrDeviceMajor :: Word+ , hdrDeviceMinor :: Word+ , hdrPrefix :: FilePath+ }+ deriving (Show)++getMembers :: Get Archive+getMembers =+ do next <- nextMember+ case next of+ Nothing -> return Map.empty+ Just (key, value) -> Map.insert key value `fmap` getMembers++nextMember :: Get (Maybe (FilePath, ArchiveMember))+nextMember =+ do nextTwoBlocks <- lookAhead (getBytes 1024)+ if B.all (== 0) nextTwoBlocks+ then return Nothing+ else Just `fmap` getArchiveMember++getArchiveMember :: Get (FilePath, ArchiveMember)+getArchiveMember =+ do hdr <- isolate 512 getProperHeader+ case hdrTypeFlag hdr of+ FlagRegularFile -> convertRegularFile hdr+ FlagLink -> convertLink LinkMember hdr+ FlagSymbolicLink -> convertLink SymbolicLinkMember hdr+ FlagCharacterDevice -> convertDevice CharacterDeviceMember hdr+ FlagBlockDevice -> convertDevice BlockDeviceMember hdr+ FlagDirectory -> convertDirectory hdr+ FlagSpecialFIFOFile -> convertFIFO hdr+ FlagReserved -> convertRegularFile hdr+ FlagCustom c -> do body <- getPaddedBody (hdrSize hdr)+ let key = hdrPrefix hdr ++ hdrFileName hdr+ return (key, CustomMember c hdr body)++data RegularFile = RegularFile+ { regFileName :: FilePath+ , regMode :: Word+ , regOwner :: Word+ , regGroup :: Word+ , regSize :: Word+ , regModificationTime :: UTCTime+ , regUserName :: String+ , regGroupName :: String+ , regContents :: ByteString+ }+ deriving (Show)++convertRegularFile :: ArchiveHeader -> Get (FilePath, ArchiveMember)+convertRegularFile hdr =+ do let regFileName = hdrPrefix hdr ++ hdrFileName hdr+ regMode = hdrMode hdr+ regOwner = hdrOwner hdr+ regGroup = hdrGroup hdr+ regSize = hdrSize hdr+ regModificationTime = hdrModificationTime hdr+ regUserName = hdrUserName hdr+ regGroupName = hdrGroupName hdr+ regContents <- getPaddedBody regSize+ return (regFileName, RegularFileMember RegularFile{..})++data Link = Link+ { linkFileName :: FilePath+ , linkMode :: Word+ , linkOwner :: Word+ , linkGroup :: Word+ , linkSize :: Word+ , linkModificationTime :: UTCTime+ , linkUserName :: String+ , linkGroupName :: String+ , linkTarget :: FilePath+ }+ deriving (Show)++convertLink :: (Link -> ArchiveMember) -> ArchiveHeader ->+ Get (FilePath, ArchiveMember)+convertLink builder hdr = return (linkFileName, builder link)+ where+ link = Link{ .. }+ linkFileName = hdrPrefix hdr ++ hdrFileName hdr+ linkMode = hdrMode hdr+ linkOwner = hdrOwner hdr+ linkGroup = hdrGroup hdr+ linkSize = hdrSize hdr+ linkModificationTime = hdrModificationTime hdr+ linkUserName = hdrUserName hdr+ linkGroupName = hdrGroupName hdr+ linkTarget = hdrLinkName hdr++data Device = Device+ { devFileName :: FilePath+ , devMode :: Word+ , devOwner :: Word+ , devGroup :: Word+ , devModificationTime :: UTCTime+ , devUserName :: String+ , devGroupName :: String+ , devMajorNumber :: Word+ , devMinorNumber :: Word+ }+ deriving (Show)+ +convertDevice :: (Device -> ArchiveMember) -> ArchiveHeader ->+ Get (FilePath, ArchiveMember)+convertDevice builder hdr = return (devFileName, builder device)+ where+ device = Device{..}+ devFileName = hdrPrefix hdr ++ hdrFileName hdr+ devMode = hdrMode hdr+ devOwner = hdrOwner hdr+ devGroup = hdrGroup hdr+ devModificationTime = hdrModificationTime hdr+ devUserName = hdrUserName hdr+ devGroupName = hdrGroupName hdr+ devMajorNumber = hdrDeviceMajor hdr+ devMinorNumber = hdrDeviceMinor hdr++data Directory = Directory+ { dirFileName :: FilePath+ , dirMode :: Word+ , dirOwner :: Word+ , dirGroup :: Word+ , dirModificationTime :: UTCTime+ , dirUserName :: String+ , dirGroupName :: String+ }+ deriving (Show)++convertDirectory :: ArchiveHeader -> Get (FilePath, ArchiveMember)+convertDirectory hdr = return (dirFileName, DirectoryMember directory)+ where+ directory = Directory{..}+ dirFileName = hdrPrefix hdr ++ hdrFileName hdr+ dirMode = hdrMode hdr+ dirOwner = hdrOwner hdr+ dirGroup = hdrGroup hdr+ dirModificationTime = hdrModificationTime hdr+ dirUserName = hdrUserName hdr+ dirGroupName = hdrGroupName hdr++data SpecialFIFOFile = SpecialFIFOFile+ { fifoFileName :: FilePath+ , fifoMode :: Word+ , fifoOwner :: Word+ , fifoGroup :: Word+ , fifoModificationTime :: UTCTime+ , fifoUserName :: String+ , fifoGroupName :: String+ }+ deriving (Show)++convertFIFO :: ArchiveHeader -> Get (FilePath, ArchiveMember)+convertFIFO hdr = return (fifoFileName, SpecialFIFOFileMember fifo)+ where+ fifo = SpecialFIFOFile{..}+ fifoFileName = hdrPrefix hdr ++ hdrFileName hdr+ fifoMode = hdrMode hdr+ fifoOwner = hdrOwner hdr+ fifoGroup = hdrGroup hdr+ fifoModificationTime = hdrModificationTime hdr+ fifoUserName = hdrUserName hdr+ fifoGroupName = hdrGroupName hdr+++getPaddedBody :: Word -> Get ByteString+getPaddedBody sizeb =+ do let blocks = (sizeb + 511) `div` 512+ padded = blocks * 512+ skipAmt = padded - sizeb+ res <- getByteString (fromIntegral sizeb)+ unless (skipAmt == 0) $ skip (fromIntegral skipAmt)+ return res++getProperHeader :: Get ArchiveHeader+getProperHeader =+ do checksum1 <- lookAhead (label "checksum computation" getChecksum)+ header <- label "archive header" getArchiveHeader+ let checksum2 = hdrChecksum header+ unless (checksum1 == checksum2) $+ fail ("Checksum mismatch: "++show checksum1++" /= "++show checksum2)+ return header++getChecksum :: Get Word+getChecksum =+ do acc0 <- addSum 0 `fmap` getByteString 100 -- name of file+ acc1 <- addSum acc0 `fmap` getByteString 8 -- file mode+ acc2 <- addSum acc1 `fmap` getByteString 8 -- user ID+ acc3 <- addSum acc2 `fmap` getByteString 8 -- group ID+ acc4 <- addSum acc3 `fmap` getByteString 12 -- length in bytes+ acc5 <- addSum acc4 `fmap` getByteString 12 -- modify time+ skip 8 -- the actual checksum+ let acc6 = addSum acc5 (BC.replicate 8 ' ')+ acc7 <- addSum acc6 `fmap` getByteString 1 -- type of file+ acc8 <- addSum acc7 `fmap` getByteString 100 -- name of linked file+ acc9 <- addSum acc8 `fmap` getByteString 6 -- USTAR indicator+ acc10 <- addSum acc9 `fmap` getByteString 2 -- USTAR version+ acc11 <- addSum acc10 `fmap` getByteString 32 -- user name+ acc12 <- addSum acc11 `fmap` getByteString 32 -- user group+ acc13 <- addSum acc12 `fmap` getByteString 8 -- device major number+ acc14 <- addSum acc13 `fmap` getByteString 8 -- device minor number+ acc15 <- addSum acc14 `fmap` getByteString 155 -- prefix file name+ skip 12 -- trailing bytes+ return acc15+ where+ addSum = B.foldl' (\ acc x -> acc + fromIntegral x)+ +getArchiveHeader :: Get ArchiveHeader+getArchiveHeader =+ do hdrFileName <- toStringLike `fmap` getByteString 100+ hdrMode <- toNumeric `fmap` getByteString 8+ hdrOwner <- toNumeric `fmap` getByteString 8+ hdrGroup <- toNumeric `fmap` getByteString 8+ hdrSize <- toNumeric `fmap` getByteString 12+ hdrModificationTime <- toUTCTime `fmap` getByteString 12+ hdrChecksum <- toNumeric `fmap` getByteString 8+ hdrTypeFlag <- toRecordTypeFlag =<< getByteString 1+ hdrLinkName <- toStringLike `fmap` getByteString 100+ hdrMagic <- toStringLike `fmap` getByteString 6+ hdrVersion <- getByteString 2+ hdrUserName <- toStringLike `fmap` getByteString 32+ hdrGroupName <- toStringLike `fmap` getByteString 32+ hdrDeviceMajor <- toNumeric `fmap` getByteString 8+ hdrDeviceMinor <- toNumeric `fmap` getByteString 8+ hdrPrefix <- toStringLike `fmap` getByteString 155+ skip 12 -- trailing bytes+ unless (hdrMagic == "ustar ") $ fail ("Bad magic value: " ++ hdrMagic ++ "(filename: " ++ show hdrFileName)+ return ArchiveHeader{..}++data RecordTypeFlag = FlagRegularFile+ | FlagLink+ | FlagSymbolicLink+ | FlagCharacterDevice+ | FlagBlockDevice+ | FlagDirectory+ | FlagSpecialFIFOFile+ | FlagReserved+ | FlagCustom Char+ deriving (Show)++toRecordTypeFlag :: ByteString -> Get RecordTypeFlag+toRecordTypeFlag x =+ case BC.uncons x of+ Nothing -> fail "The world went insane."+ Just ('\0', _) -> return FlagRegularFile+ Just ('0', _) -> return FlagRegularFile+ Just ('1', _) -> return FlagLink+ Just ('2', _) -> return FlagSymbolicLink+ Just ('3', _) -> return FlagCharacterDevice+ Just ('4', _) -> return FlagBlockDevice+ Just ('5', _) -> return FlagDirectory+ Just ('6', _) -> return FlagSpecialFIFOFile+ Just ('7', _) -> return FlagReserved+ Just (c, _) | c `elem` (['A'..'Z']++['a'..'z']) ->+ return (FlagCustom c)+ Just _ ->+ fail ("Unexpected record type: " ++ show x)++toStringLike :: IsString a => ByteString -> a+toStringLike = fromString . BC.unpack . stripTrailingNulls+ where+ stripTrailingNulls x =+ case B.unsnoc x of+ Nothing -> B.empty+ Just (x', 0) -> stripTrailingNulls x'+ Just (_, _) -> x++toNumeric :: Num a => ByteString -> a+toNumeric = parseOctal 0+ where+ parseOctal acc x =+ case BC.uncons x of+ Nothing -> acc+ Just ('\0', _) -> acc+ Just (c, rest) -> parseOctal ((acc * 8) + digitToInt' c) rest+ digitToInt' = fromIntegral . digitToInt++toUTCTime :: ByteString -> UTCTime+toUTCTime = posixSecondsToUTCTime . toNumeric