fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Bugfixes

Browse Source
This commit is contained in:
Gregor Kleen 2017-10-06 04:09:45 +02:00
parent 6c1afb6919
commit 88493d34a0
2 changed files with 23 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
src/Handler/Zip.hs
View File

@ -34,6 +34,8 @@ import Data.Time
import GHC.Generics (Generic)
import Data.Typeable (Typeable)
import Data.List (dropWhileEnd)
data ZipEntry = ZipEntry
{ zipEntryName :: FilePath
@ -60,13 +62,13 @@ consumeZip handleEntry = Zip.unZipStream `fuseBoth` consumeZip'
input <- await
case input of
Nothing -> return []
Just (Right _) -> consumeZip' -- throw $ userError "Data chunk in unexpected place when parsing ZIP"
Just (Right _) -> throw $ userError "Data chunk in unexpected place when parsing ZIP"
Just (Left e) -> do
zipEntryName' <- fmap Text.unpack . either throw return . Text.decodeUtf8' $ Zip.zipEntryName e
contentChunks <- accContents
let
zipEntryName = normalise . makeValid $ dropTrailingPathSeparator zipEntryName'
zipEntryTime = localTimeToUTC utc $ Zip.zipEntryTime e
zipEntryName = normalise $ makeValid zipEntryName'
zipEntryTime = fixZipEpoch . localTimeToUTC utc $ Zip.zipEntryTime e
zipEntryContents
| hasTrailingPathSeparator zipEntryName' = Nothing
| otherwise = Just $ Lazy.ByteString.fromChunks contentChunks
@ -76,8 +78,15 @@ consumeZip handleEntry = Zip.unZipStream `fuseBoth` consumeZip'
input <- await
case input of
Just (Right x) -> (x :) <$> accContents
Just (Left x) -> [] <$ leftover (Left x)
_ -> return []
fixZipEpoch :: UTCTime -> UTCTime
-- ^ Testing showed that the zip library used introduces a weird offset into
-- dates when packing/unpacking zip files.
-- This is fixed here, for now.
fixZipEpoch u@(UTCTime{..}) = u{ utctDay = addDays (-46751) utctDay }
produceZip :: ( MonadBase b m
, PrimMonad b
@ -101,6 +110,6 @@ produceZip info = Conduit.map toZipData =$= void (Zip.zipStream zipOptions)
toZipEntry :: Bool -- ^ Is directory?
-> ZipEntry -> Zip.ZipEntry
toZipEntry isDir ZipEntry{..} = Zip.ZipEntry
{ zipEntryName = Text.encodeUtf8 . Text.pack . normalise . makeValid . bool dropTrailingPathSeparator addTrailingPathSeparator isDir $ zipEntryName
{ zipEntryName = Text.encodeUtf8 . Text.pack . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator isDir . normalise . makeValid $ zipEntryName
, zipEntryTime = utcToLocalTime utc zipEntryTime
}

16
test/Handler/ZipSpec.hs
View File

@ -12,7 +12,9 @@ import System.FilePath
import Data.Conduit
import qualified Data.Conduit.List as Conduit
import Data.Conduit.Binary (sourceLbs, sinkLbs)
import Data.List (dropWhileEnd)
import Data.Time
instance Arbitrary ZipEntry where
arbitrary = do
@ -25,9 +27,11 @@ spec :: Spec
spec = describe "Zip file handling" $ do
it "has compatible encoding/decoding to/from zip files" . property $
\zipFiles -> do
bs <- runConduit $ Conduit.sourceList zipFiles =$= produceZip def =$= sinkLbs
(_, zipFiles') <- runConduit $ sourceLbs bs =$= consumeZip return
forM_ (zip zipFiles zipFiles') $ \(file, file') -> do
(shouldBe `on` normalise . makeValid . dropTrailingPathSeparator) (zipEntryName file') (zipEntryName file)
-- (zipEntryTime file') `shouldBe` (zipEntryTime file)
(_, zipFiles') <- runConduit $ Conduit.sourceList zipFiles =$= produceZip def =$= consumeZip return
forM_ (zipFiles `zip` zipFiles') $ \(file, file') -> do
let acceptableFilenameChanges
= bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator (isNothing $ zipEntryContents file) . normalise . makeValid
acceptableTimeDifference t1 t2 = abs (diffUTCTime t1 t2) <= 2
(shouldBe `on` acceptableFilenameChanges) (zipEntryName file') (zipEntryName file)
(zipEntryTime file', zipEntryTime file) `shouldSatisfy` uncurry acceptableTimeDifference
(zipEntryContents file') `shouldBe` (zipEntryContents file)