fraport/fradrive-old
Archived
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 GHC.Generics (Generic)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Data.List (dropWhileEnd)
data ZipEntry = ZipEntry data ZipEntry = ZipEntry
{ zipEntryName :: FilePath { zipEntryName :: FilePath
@ -60,13 +62,13 @@ consumeZip handleEntry = Zip.unZipStream `fuseBoth` consumeZip'
input <- await input <- await
case input of case input of
Nothing -> return [] 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 Just (Left e) -> do
zipEntryName' <- fmap Text.unpack . either throw return . Text.decodeUtf8' $ Zip.zipEntryName e zipEntryName' <- fmap Text.unpack . either throw return . Text.decodeUtf8' $ Zip.zipEntryName e
contentChunks <- accContents contentChunks <- accContents
let let
zipEntryName = normalise . makeValid $ dropTrailingPathSeparator zipEntryName' zipEntryName = normalise $ makeValid zipEntryName'
zipEntryTime = localTimeToUTC utc $ Zip.zipEntryTime e zipEntryTime = fixZipEpoch . 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
@ -76,8 +78,15 @@ consumeZip handleEntry = Zip.unZipStream `fuseBoth` consumeZip'
input <- await input <- await
case input of case input of
Just (Right x) -> (x :) <$> accContents Just (Right x) -> (x :) <$> accContents
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
@ -101,6 +110,6 @@ produceZip info = Conduit.map toZipData =$= void (Zip.zipStream zipOptions)
toZipEntry :: Bool -- ^ Is directory? toZipEntry :: Bool -- ^ Is directory?
-> ZipEntry -> Zip.ZipEntry -> ZipEntry -> Zip.ZipEntry
toZipEntry isDir 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 , zipEntryTime = utcToLocalTime utc zipEntryTime
} }

16
test/Handler/ZipSpec.hs
View File

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