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

Address date confusion

Browse Source
This commit is contained in:
Gregor Kleen 2017-10-09 14:07:27 +02:00
parent 88493d34a0
commit 5742d21406
2 changed files with 14 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
src/Handler/Zip.hs
View File

@ -68,7 +68,7 @@ consumeZip handleEntry = Zip.unZipStream `fuseBoth` consumeZip'
contentChunks <- accContents contentChunks <- accContents
let let
zipEntryName = normalise $ makeValid zipEntryName' zipEntryName = normalise $ makeValid zipEntryName'
zipEntryTime = fixZipEpoch . localTimeToUTC utc $ Zip.zipEntryTime e zipEntryTime = localTimeToUTC utc $ Zip.zipEntryTime e
zipEntryContents zipEntryContents
| hasTrailingPathSeparator zipEntryName' = Nothing | hasTrailingPathSeparator zipEntryName' = Nothing
| otherwise = Just $ Lazy.ByteString.fromChunks contentChunks | otherwise = Just $ Lazy.ByteString.fromChunks contentChunks
@ -81,13 +81,6 @@ consumeZip handleEntry = Zip.unZipStream `fuseBoth` consumeZip'
Just (Left x) -> [] <$ leftover (Left x) Just (Left x) -> [] <$ leftover (Left x)
_ -> return [] _ -> 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 produceZip :: ( MonadBase b m
, PrimMonad b , PrimMonad b
, MonadThrow m , MonadThrow m

16
test/Handler/ZipSpec.hs
View File

@ -19,7 +19,8 @@ import Data.Time
instance Arbitrary ZipEntry where instance Arbitrary ZipEntry where
arbitrary = do arbitrary = do
zipEntryName <- joinPath <$> arbitrary zipEntryName <- joinPath <$> arbitrary
zipEntryTime <- arbitrary let date = addDays <$> arbitrary <*> pure (fromGregorian 2043 7 2)
zipEntryTime <- UTCTime <$> date <*> arbitrary
zipEntryContents <- arbitrary zipEntryContents <- arbitrary
return ZipEntry{..} return ZipEntry{..}
@ -30,8 +31,17 @@ spec = describe "Zip file handling" $ do
(_, zipFiles') <- runConduit $ Conduit.sourceList zipFiles =$= produceZip def =$= consumeZip return (_, zipFiles') <- runConduit $ Conduit.sourceList zipFiles =$= produceZip def =$= consumeZip return
forM_ (zipFiles `zip` zipFiles') $ \(file, file') -> do forM_ (zipFiles `zip` zipFiles') $ \(file, file') -> do
let acceptableFilenameChanges let acceptableFilenameChanges
= bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator (isNothing $ zipEntryContents file) . normalise . makeValid = makeValid . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator (isNothing $ zipEntryContents file) . normalise . makeValid
acceptableTimeDifference t1 t2 = abs (diffUTCTime t1 t2) <= 2 acceptableTimeDifference t1 t2 = abs (diffUTCTime t1 t2) <= 2
(shouldBe `on` acceptableFilenameChanges) (zipEntryName file') (zipEntryName file) (shouldBe `on` acceptableFilenameChanges) (zipEntryName file') (zipEntryName file)
(zipEntryTime file', zipEntryTime file) `shouldSatisfy` uncurry acceptableTimeDifference when (inZipRange $ zipEntryTime file) $
(zipEntryTime file', zipEntryTime file) `shouldSatisfy` uncurry acceptableTimeDifference
(zipEntryContents file') `shouldBe` (zipEntryContents file) (zipEntryContents file') `shouldBe` (zipEntryContents file)
inZipRange :: UTCTime -> Bool
inZipRange time
| time > UTCTime (fromGregorian 1980 1 1) 0
, time < UTCTime (fromGregorian 2107 1 1) 0
= True
| otherwise
= False