1 {-# LANGUAGE OverloadedStrings #-} 2 module Controller.Zip 3 ( zipContainer 4 , zipVolume 5 , viewVolumeDescription 6 ) where 7 8 import qualified Data.ByteString as BS 9 import qualified Data.ByteString.Builder as BSB 10 import qualified Data.ByteString.Char8 as BSC 11 import qualified Data.ByteString.Lazy as BSL 12 import Data.Function (on) 13 import Data.List (groupBy, partition) 14 import Data.Maybe (fromJust, maybeToList) 15 import Control.Monad.IO.Class (liftIO) 16 import Data.Monoid ((<>)) 17 import qualified Data.RangeSet.List as RS 18 import qualified Data.Text.Encoding as TE 19 import Network.HTTP.Types (hContentType, hCacheControl, hContentLength) 20 import System.Posix.FilePath ((<.>)) 21 import qualified Text.Blaze.Html5 as Html 22 import qualified Text.Blaze.Html.Renderer.Utf8 as Html 23 import qualified Codec.Archive.Zip as ZIP 24 import qualified System.IO as IO 25 import qualified System.Directory as DIR 26 import qualified Conduit as CND 27 import Path (parseRelFile) 28 29 import Ops 30 import Has (view, peek, peeks) 31 import Store.Asset 32 import Store.Filename 33 import Store.CSV (buildCSV) 34 import Store.Types 35 import Model.Id 36 import Model.Permission 37 import Model.Volume 38 import Model.Container 39 import Model.Slot 40 import Model.RecordSlot 41 import Model.Asset 42 import Model.AssetSlot 43 import Model.Format 44 import Model.Party 45 import Model.Citation 46 import Model.Funding 47 import HTTP 48 import HTTP.Path.Parser 49 import Action 50 import Controller.Paths 51 import Controller.Asset 52 import Controller.Container 53 import Controller.Volume 54 import Controller.Party 55 import Controller.CSV 56 import Controller.Angular 57 import Controller.IdSet 58 import View.Zip 59 60 -- isOrig flags have been added to toggle the ability to access the pre-transcoded asset 61 assetZipEntry2 :: Bool -> BS.ByteString -> AssetSlot -> Handler (ZIP.ZipArchive ()) 62 assetZipEntry2 isOrig containerDir AssetSlot{ slotAsset = a@Asset{ assetRow = ar@AssetRow{ assetId = aid}}} = do 63 origAsset <- lookupOrigAsset aid 64 Just f <- case isOrig of 65 True -> getAssetFile $ fromJust origAsset 66 False -> getAssetFile a 67 req <- peek 68 let entryName = 69 containerDir `BS.append` (case isOrig of 70 False -> makeFilename (assetDownloadName True False ar) `addFormatExtension` assetFormat ar 71 True -> makeFilename (assetDownloadName False True ar) `addFormatExtension` assetFormat ar) 72 entrySelector <- liftIO (parseRelFile (BSC.unpack entryName) >>= ZIP.mkEntrySelector) 73 return 74 (do 75 ZIP.sinkEntry ZIP.Store (CND.sourceFileBS (BSC.unpack f)) entrySelector 76 ZIP.setEntryComment (TE.decodeUtf8 $ BSL.toStrict $ BSB.toLazyByteString $ actionURL (Just req) viewAsset (HTML, assetId ar) []) entrySelector) 77 78 containerZipEntry2 :: Bool -> BS.ByteString -> Container -> [AssetSlot] -> Handler (ZIP.ZipArchive ()) 79 containerZipEntry2 isOrig prefix c l = do 80 let containerDir = prefix <> makeFilename (containerDownloadName c) <> "/" 81 zipActs <- mapM (assetZipEntry2 isOrig containerDir) l 82 return (sequence_ zipActs) 83 84 volumeDescription :: Bool -> Volume -> (Container, [RecordSlot]) -> IdSet Container -> [AssetSlot] -> Handler (Html.Html, [[AssetSlot]], [[AssetSlot]]) 85 volumeDescription inzip v (_, glob) cs al = do 86 cite <- lookupVolumeCitation v 87 links <- lookupVolumeLinks v 88 fund <- lookupVolumeFunding v 89 desc <- peeks $ htmlVolumeDescription inzip v (maybeToList cite ++ links) fund glob cs at ab 90 return (desc, at, ab) 91 where 92 (at, ab) = partition (any (containerTop . containerRow . slotContainer) . assetSlot . head) $ groupBy (me `on` fmap (containerId . containerRow . slotContainer) . assetSlot) al 93 me (Just x) (Just y) = x == y 94 me _ _ = False 95 96 volumeZipEntry2 :: Bool -> Volume -> (Container, [RecordSlot]) -> IdSet Container -> Maybe BSB.Builder -> [AssetSlot] -> Handler (ZIP.ZipArchive ()) 97 volumeZipEntry2 isOrig v top cs csv al = do 98 (desc, at, ab) <- volumeDescription True v top cs al -- the actual asset slot's assets arent' used any more for containers, now container zip entry does that 99 let zipDir = makeFilename (volumeDownloadName v ++ if idSetIsFull cs then [] else ["PARTIAL"]) <> "/" 100 zt <- mapM (ent zipDir) at 101 zb <- mapM (ent (zipDir <> "sessions/")) ab 102 descEntrySelector <- liftIO (parseRelFile (BSC.unpack zipDir <> "description.html") >>= ZIP.mkEntrySelector) 103 spreadEntrySelector <- liftIO (parseRelFile (BSC.unpack zipDir <> "spreadsheet.csv") >>= ZIP.mkEntrySelector) 104 return 105 (do 106 sequence_ zt 107 sequence_ zb 108 ZIP.addEntry ZIP.Store (BSL.toStrict (Html.renderHtml desc)) descEntrySelector 109 maybe (pure ()) (\c -> ZIP.addEntry ZIP.Store (BSL.toStrict (BSB.toLazyByteString c)) spreadEntrySelector) csv) 110 where 111 ent prefix [a@AssetSlot{ assetSlot = Nothing }] = assetZipEntry2 isOrig prefix a -- orig asset doesn't matter here as top level assets aren't transcoded, I believe 112 ent prefix (AssetSlot{ assetSlot = Just s } : _) = do 113 (acts, _) <- containerZipEntryCorrectAssetSlots2 isOrig prefix (slotContainer s) 114 pure acts 115 ent _ _ = fail "volumeZipEntry" 116 117 zipResponse2 :: BS.ByteString -> ZIP.ZipArchive () -> Handler Response 118 zipResponse2 n zipAddActions = do 119 req <- peek 120 u <- peek 121 store <- peek 122 let comment = BSL.toStrict $ BSB.toLazyByteString 123 $ BSB.string8 "Downloaded by " <> TE.encodeUtf8Builder (partyName $ partyRow u) <> BSB.string8 " <" <> actionURL (Just req) viewParty (HTML, TargetParty $ partyId $ partyRow u) [] <> BSB.char8 '>' 124 let temporaryZipName = (BSC.unpack . storageTemp) store <> "placeholder.zip" -- TODO: generate temporary name for extra caution? 125 h <- liftIO $ IO.openFile temporaryZipName IO.ReadWriteMode 126 liftIO $ DIR.removeFile temporaryZipName 127 liftIO $ IO.hSetBinaryMode h True 128 liftIO $ ZIP.createBlindArchive h $ do 129 ZIP.setArchiveComment (TE.decodeUtf8 comment) 130 zipAddActions 131 sz <- liftIO (IO.hSeek h IO.SeekFromEnd 0 >> IO.hTell h) 132 liftIO $ IO.hSeek h IO.AbsoluteSeek 0 133 return $ okResponse 134 [ (hContentType, "application/zip") 135 , ("content-disposition", "attachment; filename=" <> quoteHTTP (n <.> "zip")) 136 , (hCacheControl, "max-age=31556926, private") 137 , (hContentLength, BSC.pack $ show sz) 138 ] (CND.bracketP (return h) IO.hClose CND.sourceHandle :: CND.Source (CND.ResourceT IO) BS.ByteString) 139 140 checkAsset :: AssetSlot -> Bool 141 checkAsset a = 142 canReadData2 getAssetSlotRelease2 getAssetSlotVolumePermission2 a && assetBacked (view a) 143 144 containerZipEntryCorrectAssetSlots2 :: Bool -> BS.ByteString -> Container -> Handler (ZIP.ZipArchive (), Bool) 145 containerZipEntryCorrectAssetSlots2 isOrig prefix c = do 146 c'<- lookupContainerAssets c 147 assetSlots <- case isOrig of 148 True -> do 149 origs <- lookupOrigContainerAssets c 150 let pdfs = filterFormat c' formatNotAV 151 return $ pdfs ++ origs 152 False -> return c' 153 let checkedAssetSlots = filter checkAsset assetSlots 154 zipActs <- containerZipEntry2 isOrig prefix c checkedAssetSlots 155 pure (zipActs, null checkedAssetSlots) 156 157 zipContainer :: Bool -> ActionRoute (Maybe (Id Volume), Id Slot) 158 zipContainer isOrig = 159 let zipPath = case isOrig of 160 True -> pathMaybe pathId </> pathSlotId </< "zip" </< "true" 161 False -> pathMaybe pathId </> pathSlotId </< "zip" </< "false" 162 in action GET zipPath $ \(vi, ci) -> withAuth $ do 163 c <- getContainer PermissionPUBLIC vi ci True 164 let v = containerVolume c 165 _ <- maybeAction (if volumeIsPublicRestricted v then Nothing else Just ()) -- block if restricted 166 (zipActs, isEmpty) <- containerZipEntryCorrectAssetSlots2 isOrig "" c 167 auditSlotDownload (not isEmpty) (containerSlot c) 168 zipResponse2 ("databrary-" <> BSC.pack (show $ volumeId $ volumeRow $ containerVolume c) <> "-" <> BSC.pack (show $ containerId $ containerRow c)) zipActs 169 170 getVolumeInfo :: Id Volume -> Handler (Volume, IdSet Container, [AssetSlot]) 171 getVolumeInfo vi = do 172 v <- getVolume PermissionPUBLIC vi 173 _ <- maybeAction (if volumeIsPublicRestricted v then Nothing else Just ()) -- block if restricted 174 s <- peeks requestIdSet 175 -- let isMember = maybe (const False) (\c -> RS.member (containerId $ containerRow $ slotContainer $ c)) 176 -- non-exhaustive pattern found here ...v , implment in case of Nothing (Keep in mind originalAssets will not have containers, or Volumes) 177 a <- filter (\a@AssetSlot{ assetSlot = Just c } -> checkAsset a && RS.member (containerId $ containerRow $ slotContainer c) s) <$> lookupVolumeAssetSlots v False 178 return (v, s, a) 179 180 filterFormat :: [AssetSlot] -> (Format -> Bool)-> [AssetSlot] 181 filterFormat as f = filter (f . assetFormat . assetRow . slotAsset ) as 182 183 zipVolume :: Bool -> ActionRoute (Id Volume) 184 zipVolume isOrig = 185 let zipPath = case isOrig of 186 True -> pathId </< "zip" </< "true" 187 False -> pathId </< "zip" </< "false" 188 in action GET zipPath $ \vi -> withAuth $ do 189 (v, s, a) <- getVolumeInfo vi 190 top:cr <- lookupVolumeContainersRecords v 191 let cr' = filter ((`RS.member` s) . containerId . containerRow . fst) cr 192 csv <- null cr' `unlessReturn` volumeCSV v cr' 193 zipActs <- volumeZipEntry2 isOrig v top s (buildCSV <$> csv) a 194 auditVolumeDownload (not $ null a) v 195 zipResponse2 (BSC.pack $ "databrary-" ++ show (volumeId $ volumeRow v) ++ if idSetIsFull s then "" else "-partial") zipActs 196 197 viewVolumeDescription :: ActionRoute (Id Volume) 198 viewVolumeDescription = action GET (pathId </< "description") $ \_ -> withAuth $ do 199 angular 200 {- 201 (v, s, a) <- getVolumeInfo vi 202 top <- lookupVolumeTopContainer v 203 glob <- lookupSlotRecords $ containerSlot top 204 (desc, _, _) <- volumeDescription False v (top, glob) s a 205 -} 206 return $ okResponse [] (""::String)