{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
module System.DirTree.Zip
( entriesToDirForest
, entriesFromDirForest
, entryToDirForest
, entryFromFile
, files
, entries
, toArchive
, fromArchive
)
where
import Data.Foldable
import Data.Maybe
import Data.Bits
import System.Posix.Files ( symbolicLinkMode
, stdFileMode
)
import Control.Lens
import Codec.Archive.Zip
import System.DirTree
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC
entryToDirForest :: Entry -> Maybe (DirForest Entry)
entryToDirForest e = flip createDeepForest (file e)
<$> toForestFileKey (fileKeyFromPath (eRelativePath e))
entriesToDirForest :: [Entry] -> Maybe (RelativeDirForest Link BL.ByteString)
entriesToDirForest = fmap (imap parseEntry . fold) . traverse entryToDirForest
where
parseEntry key e = case symbolicLinkEntryTarget e of
Just f -> Symlink . toLink (fromForestFileKey key) $ f
Nothing -> Real $ fromEntry e
entryFromFile :: Integer -> FileKey -> RelativeFile Link BL.ByteString -> Entry
entryFromFile i key = \case
Real bs -> toEntry (fileKeyToPath key) i bs
Symlink x -> toSymlinkEntry (fileKeyToPath key) $ case x of
Internal trgt -> diffFileKey (init key) trgt
External f -> f
where
toSymlinkEntry path t =
let e = toEntry path i (BLC.pack t)
shiftlength = fromIntegral (symbolicLinkMode .|. stdFileMode)
in e
{ eExternalFileAttributes = eExternalFileAttributes e
.|. shiftL shiftlength 16
, eVersionMadeBy = 798
}
entriesFromDirForest
:: Integer -> RelativeDirForest Link BL.ByteString -> [Entry]
entriesFromDirForest i = toList . imap (entryFromFile i . fromForestFileKey)
entries :: Lens' Archive [Entry]
entries = lens zEntries (\a b -> a { zEntries = b })
entriesAsDirForest
:: Integer -> Iso' [Entry] (RelativeDirForest Link BL.ByteString)
entriesAsDirForest i = iso from' to' where
from' = fromJust . entriesToDirForest
to' = entriesFromDirForest i
files :: Lens' Archive (RelativeDirForest Link BL.ByteString)
files = entries . entriesAsDirForest 0