<commit_before>{-# LANGUAGE OverloadedStrings, ViewPatterns #-}
module Databrary.Controller.Zip
  ( zipContainer
  , zipVolume
  , viewVolumeDescription
  , zipContainerOld -- DELETE ME
  ) where

import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BSL
import Data.Function (on)
import Data.List (groupBy, partition)
import Data.Maybe (fromJust, maybeToList)
import Control.Monad.IO.Class (liftIO)
import Data.Monoid ((<>))
import qualified Data.RangeSet.List as RS
import qualified Data.Text.Encoding as TE
import Network.HTTP.Types (hContentType, hCacheControl, hContentLength)
import System.Posix.FilePath ((<.>))
import qualified Text.Blaze.Html5 as Html
import qualified Text.Blaze.Html.Renderer.Utf8 as Html
import qualified Codec.Archive.Zip as ZIP
import qualified System.IO as IO
import qualified System.Directory as DIR
import qualified Conduit as CND
import Path (parseRelFile)
import Path.IO (resolveFile')

import Databrary.Ops
import Databrary.Has (view, peek, peeks)
import Databrary.Store.Asset
import Databrary.Store.Filename
import Databrary.Store.CSV (buildCSV)
import Databrary.Store.Zip
import Databrary.Model.Id
import Databrary.Model.Permission
import Databrary.Model.Volume
import Databrary.Model.Container
import Databrary.Model.Slot
import Databrary.Model.RecordSlot
import Databrary.Model.Asset
import Databrary.Model.AssetSlot
import Databrary.Model.Format
import Databrary.Model.Party
import Databrary.Model.Citation
import Databrary.Model.Funding
import Databrary.HTTP
import Databrary.HTTP.Path.Parser
import Databrary.Action
import Databrary.Controller.Paths
import Databrary.Controller.Asset
import Databrary.Controller.Container
import Databrary.Controller.Volume
import Databrary.Controller.Party
import Databrary.Controller.CSV
import Databrary.Controller.Angular
import Databrary.Controller.IdSet
import Databrary.View.Zip

-- isOrig flags have been added to toggle the ability to access the pre-transcoded asset
assetZipEntry :: Bool -> AssetSlot -> ActionM ZipEntry
assetZipEntry isOrig AssetSlot{ slotAsset = a@Asset{ assetRow = ar@AssetRow{ assetId = aid}}} = do
  origAsset <- lookupOrigAsset aid   
  Just f <- case isOrig of 
                 True -> getAssetFile $ fromJust origAsset
                 False -> getAssetFile a
  req <- peek
  -- (t, _) <- assetCreation a
  -- Just (t, s) <- fileInfo f
  -- liftIO (print ("downloadname", assetDownloadName False True ar))
  -- liftIO (print ("format", assetFormat ar))
  return blankZipEntry
    { zipEntryName = case isOrig of
       False -> makeFilename (assetDownloadName True False ar) `addFormatExtension` assetFormat ar
       True -> makeFilename (assetDownloadName False True ar) `addFormatExtension` assetFormat ar
    , zipEntryTime = Nothing
    , zipEntryComment = BSL.toStrict $ BSB.toLazyByteString $ actionURL (Just req) viewAsset (HTML, assetId ar) []
    , zipEntryContent = ZipEntryFile (fromIntegral $ fromJust $ assetSize ar) f
    }

containerZipEntry :: Bool -> Container -> [AssetSlot] -> ActionM ZipEntry
containerZipEntry isOrig c l = do
  req <- peek
  a <- mapM (assetZipEntry isOrig) l
  return blankZipEntry
    { zipEntryName = makeFilename (containerDownloadName c)
    , zipEntryComment = BSL.toStrict $ BSB.toLazyByteString $ actionURL (Just req) viewContainer (HTML, (Nothing, containerId $ containerRow c)) []
    , zipEntryContent = ZipDirectory a
    }

volumeDescription :: Bool -> Volume -> (Container, [RecordSlot]) -> IdSet Container -> [AssetSlot] -> ActionM (Html.Html, [[AssetSlot]], [[AssetSlot]])
volumeDescription inzip v (_, glob) cs al = do
  cite <- lookupVolumeCitation v
  links <- lookupVolumeLinks v
  fund <- lookupVolumeFunding v
  desc <- peeks $ htmlVolumeDescription inzip v (maybeToList cite ++ links) fund glob cs at ab
  return (desc, at, ab)
  where
  (at, ab) = partition (any (containerTop . containerRow . slotContainer) . assetSlot . head) $ groupBy (me `on` fmap (containerId . containerRow . slotContainer) . assetSlot) al
  me (Just x) (Just y) = x == y
  me _ _ = False

volumeZipEntry :: Bool -> Volume -> (Container, [RecordSlot]) -> IdSet Container -> Maybe BSB.Builder -> [AssetSlot] -> ActionM ZipEntry
volumeZipEntry isOrig v top cs csv al = do
  req <- peek
  (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
  zt <- mapM ent at 
  zb <- mapM ent ab
  return blankZipEntry
    { zipEntryName = makeFilename $ volumeDownloadName v ++ if idSetIsFull cs then [] else ["PARTIAL"]
    , zipEntryComment = BSL.toStrict $ BSB.toLazyByteString $ actionURL (Just req) viewVolume (HTML, volumeId $ volumeRow v) []
    , zipEntryContent = ZipDirectory
      $ blankZipEntry
        { zipEntryName = "description.html"
        , zipEntryContent = ZipEntryPure $ Html.renderHtml $ desc
        }
      : maybe id (\c -> (blankZipEntry
        { zipEntryName = "spreadsheet.csv"
        , zipEntryContent = ZipEntryPure $ BSB.toLazyByteString c
        } :)) csv
      (if null zb then zt else (zt ++ [blankZipEntry
        { zipEntryName = "sessions"
        , zipEntryContent = ZipDirectory zb
        }]))
    }
  where
  ent [a@AssetSlot{ assetSlot = Nothing }] = assetZipEntry isOrig a -- orig asset doesn't matter here as top level assets aren't transcoded, I believe
  ent (AssetSlot{ assetSlot = Just s } : _) =
    containerZipEntryCorrectAssetSlots isOrig (slotContainer s)
  ent _ = fail "volumeZipEntry"

zipResponse :: BS.ByteString -> [ZipEntry] -> ActionM Response
zipResponse n z = do
  req <- peek
  u <- peek
  let comment = BSL.toStrict $ BSB.toLazyByteString
        $ BSB.string8 "Downloaded by " <> TE.encodeUtf8Builder (partyName $ partyRow u) <> BSB.string8 " <" <> actionURL (Just req) viewParty (HTML, TargetParty $ partyId $ partyRow u) [] <> BSB.char8 '>'
  return $ okResponse
    [ (hContentType, "application/zip")
    , ("content-disposition", "attachment; filename=" <> quoteHTTP (n <.> "zip"))
    , (hCacheControl, "max-age=31556926, private")
    , (hContentLength, BSC.pack $ show $ sizeZip z + fromIntegral (BS.length comment))
    ] (streamZip z comment)

zipResponse2 :: BS.ByteString -> ZIP.ZipArchive () -> ActionM Response
zipResponse2 n zipAddActions = do
  req <- peek
  u <- peek
  let comment = BSL.toStrict $ BSB.toLazyByteString
        $ BSB.string8 "Downloaded by " <> TE.encodeUtf8Builder (partyName $ partyRow u) <> BSB.string8 " <" <> actionURL (Just req) viewParty (HTML, TargetParty $ partyId $ partyRow u) [] <> BSB.char8 '>'
  let temporaryZipName = "/tmp/placeholder.zip" -- TODO: generate temporary name for extra caution?
  h <- liftIO $ IO.openFile temporaryZipName IO.ReadWriteMode
  liftIO $ DIR.removeFile temporaryZipName
  liftIO $ IO.hSetBinaryMode h True
  liftIO $ ZIP.createBlindArchive h $ do
    ZIP.setArchiveComment (TE.decodeUtf8 comment)
    zipAddActions
  sz <- liftIO $ (IO.hSeek h IO.SeekFromEnd 0 >> IO.hTell h)
  liftIO $ IO.hSeek h IO.AbsoluteSeek 0
  return $ okResponse
    [ (hContentType, "application/zip")<commit_msg>asset zip entry start to produce new zip entry action instead of data only<commit_after>{-# LANGUAGE OverloadedStrings, ViewPatterns #-}
module Databrary.Controller.Zip
  ( zipContainer
  , zipVolume
  , viewVolumeDescription
  , zipContainerOld -- DELETE ME
  ) where

import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BSL
import Data.Function (on)
import Data.List (groupBy, partition)
import Data.Maybe (fromJust, maybeToList)
import Control.Monad.IO.Class (liftIO)
import Data.Monoid ((<>))
import qualified Data.RangeSet.List as RS
import qualified Data.Text.Encoding as TE
import Network.HTTP.Types (hContentType, hCacheControl, hContentLength)
import System.Posix.FilePath ((<.>))
import qualified Text.Blaze.Html5 as Html
import qualified Text.Blaze.Html.Renderer.Utf8 as Html
import qualified Codec.Archive.Zip as ZIP
import qualified System.IO as IO
import qualified System.Directory as DIR
import qualified Conduit as CND
import Path (parseRelFile)
import Path.IO (resolveFile')

import Databrary.Ops
import Databrary.Has (view, peek, peeks)
import Databrary.Store.Asset
import Databrary.Store.Filename
import Databrary.Store.CSV (buildCSV)
import Databrary.Store.Zip
import Databrary.Model.Id
import Databrary.Model.Permission
import Databrary.Model.Volume
import Databrary.Model.Container
import Databrary.Model.Slot
import Databrary.Model.RecordSlot
import Databrary.Model.Asset
import Databrary.Model.AssetSlot
import Databrary.Model.Format
import Databrary.Model.Party
import Databrary.Model.Citation
import Databrary.Model.Funding
import Databrary.HTTP
import Databrary.HTTP.Path.Parser
import Databrary.Action
import Databrary.Controller.Paths
import Databrary.Controller.Asset
import Databrary.Controller.Container
import Databrary.Controller.Volume
import Databrary.Controller.Party
import Databrary.Controller.CSV
import Databrary.Controller.Angular
import Databrary.Controller.IdSet
import Databrary.View.Zip

-- isOrig flags have been added to toggle the ability to access the pre-transcoded asset
assetZipEntry :: Bool -> AssetSlot -> ActionM ZipEntry
assetZipEntry isOrig AssetSlot{ slotAsset = a@Asset{ assetRow = ar@AssetRow{ assetId = aid}}} = do
  origAsset <- lookupOrigAsset aid   
  Just f <- case isOrig of 
                 True -> getAssetFile $ fromJust origAsset
                 False -> getAssetFile a
  req <- peek
  -- (t, _) <- assetCreation a
  -- Just (t, s) <- fileInfo f
  -- liftIO (print ("downloadname", assetDownloadName False True ar))
  -- liftIO (print ("format", assetFormat ar))
  return blankZipEntry
    { zipEntryName = case isOrig of
       False -> makeFilename (assetDownloadName True False ar) `addFormatExtension` assetFormat ar
       True -> makeFilename (assetDownloadName False True ar) `addFormatExtension` assetFormat ar
    , zipEntryTime = Nothing
    , zipEntryComment = BSL.toStrict $ BSB.toLazyByteString $ actionURL (Just req) viewAsset (HTML, assetId ar) []
    , zipEntryContent = ZipEntryFile (fromIntegral $ fromJust $ assetSize ar) f
    }

-- isOrig flags have been added to toggle the ability to access the pre-transcoded asset
assetZipEntry2 :: Bool -> BS.ByteString -> AssetSlot -> ActionM (ZIP.ZipArchive ())
assetZipEntry2 isOrig containerDir AssetSlot{ slotAsset = a@Asset{ assetRow = ar@AssetRow{ assetId = aid}}} = do
  origAsset <- lookupOrigAsset aid   
  Just f <- case isOrig of 
                 True -> getAssetFile $ fromJust origAsset
                 False -> getAssetFile a
  -- req <- peek
  -- (t, _) <- assetCreation a
  -- Just (t, s) <- fileInfo f
  -- liftIO (print ("downloadname", assetDownloadName False True ar))
  -- liftIO (print ("format", assetFormat ar))
  let entryName =
        containerDir `BS.append` (case isOrig of
          False -> makeFilename (assetDownloadName True False ar) `addFormatExtension` assetFormat ar
          True -> makeFilename (assetDownloadName False True ar) `addFormatExtension` assetFormat ar)
  entrySelector <- liftIO $ (parseRelFile (BSC.unpack entryName) >>= ZIP.mkEntrySelector)
  return
    (do
       -- TODO: comment
       -- TODO: size?
       ZIP.sinkEntry ZIP.Store (CND.sourceFileBS (BSC.unpack f)) entrySelector)
  {- blankZipEntry
    { zipEntryName = case isOrig of
       False -> makeFilename (assetDownloadName True False ar) `addFormatExtension` assetFormat ar
       True -> makeFilename (assetDownloadName False True ar) `addFormatExtension` assetFormat ar
    , zipEntryTime = Nothing
    , zipEntryComment = BSL.toStrict $ BSB.toLazyByteString $ actionURL (Just req) viewAsset (HTML, assetId ar) []
    , zipEntryContent = ZipEntryFile (fromIntegral $ fromJust $ assetSize ar) f
    }
  -}
  
containerZipEntry :: Bool -> Container -> [AssetSlot] -> ActionM ZipEntry
containerZipEntry isOrig c l = do
  req <- peek
  a <- mapM (assetZipEntry isOrig) l
  return blankZipEntry
    { zipEntryName = makeFilename (containerDownloadName c)
    , zipEntryComment = BSL.toStrict $ BSB.toLazyByteString $ actionURL (Just req) viewContainer (HTML, (Nothing, containerId $ containerRow c)) []
    , zipEntryContent = ZipDirectory a
    }

containerZipEntry2 :: Bool -> Container -> [AssetSlot] -> ActionM (ZIP.ZipArchive ())
containerZipEntry2 isOrig c l = do
  -- req <- peek
  let containerDir = makeFilename (containerDownloadName c) <> "/"
  -- zipActs <- mapM (assetZipEntry2 isOrig containerDir) l
  return (pure ()) -- blankZipEntry -- No way to add directory entry to zip with "zip" library
    -- { zipEntryName = makeFilename (containerDownloadName c)
    -- , zipEntryComment = BSL.toStrict $ BSB.toLazyByteString $ actionURL (Just req) viewContainer (HTML, (Nothing, containerId $ containerRow c)) []
    -- , zipEntryContent = ZipDirectory a
    -- }

volumeDescription :: Bool -> Volume -> (Container, [RecordSlot]) -> IdSet Container -> [AssetSlot] -> ActionM (Html.Html, [[AssetSlot]], [[AssetSlot]])
volumeDescription inzip v (_, glob) cs al = do
  cite <- lookupVolumeCitation v
  links <- lookupVolumeLinks v
  fund <- lookupVolumeFunding v
  desc <- peeks $ htmlVolumeDescription inzip v (maybeToList cite ++ links) fund glob cs at ab
  return (desc, at, ab)
  where
  (at, ab) = partition (any (containerTop . containerRow . slotContainer) . assetSlot . head) $ groupBy (me `on` fmap (containerId . containerRow . slotContainer) . assetSlot) al
  me (Just x) (Just y) = x == y
  me _ _ = False

volumeZipEntry :: Bool -> Volume -> (Container, [RecordSlot]) -> IdSet Container -> Maybe BSB.Builder -> [AssetSlot] -> ActionM ZipEntry
volumeZipEntry isOrig v top cs csv al = do
  req <- peek
  (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
  zt <- mapM ent at 
  zb <- mapM ent ab
  return blankZipEntry
    { zipEntryName = makeFilename $ volumeDownloadName v ++ if idSetIsFull cs then [] else ["PARTIAL"]
    , zipEntryComment = BSL.toStrict $ BSB.toLazyByteString $ actionURL (Just req) viewVolume (HTML, volumeId $ volumeRow v) []
    , zipEntryContent = ZipDirectory
      $ blankZipEntry
        { zipEntryName = "description.html"
        , zipEntryContent = ZipEntryPure $ Html.renderHtml $ desc
        }
      : maybe id (\c -> (blankZipEntry
        { zipEntryName = "spreadsheet.csv"
        , zipEntryContent = ZipEntryPure $ BSB.toLazyByteString c
        } :)) csv
      (if null zb then zt else (zt ++ [blankZipEntry
        { zipEntryName = "sessions"
        , zipEntryContent = ZipDirectory zb
        }]))
    }
  where
  ent [a@AssetSlot{ assetSlot = Nothing }] = assetZipEntry isOrig a -- orig asset doesn't matter here as top level assets aren't transcoded, I believe
  ent (AssetSlot{ assetSlot = Just s } : _) =
    containerZipEntryCorrectAssetSlots isOrig (slotContainer s)
  ent _ = fail "volumeZipEntry"

zipResponse :: BS.ByteString -> [ZipEntry] -> ActionM Response
zipResponse n z = do
  req <- peek
  u <- peek
  let comment = BSL.toStrict $ BSB.toLazyByteString
        $ BSB.string8 "Downloaded by " <> TE.encodeUtf8Builder (partyName $ partyRow u) <> BSB.string8 " <" <> actionURL (Just req) viewParty (HTML, TargetParty $ partyId $ partyRow u) [] <> BSB.char8 '>'
  return $ okResponse
    [ (hContentType, "application/zip")
    , ("content-disposition", "attachment; filename=" <> quoteHTTP (n <.> "zip"))
    , (hCacheControl, "max-age=31556926, private")
    , (hContentLength, BSC.pack $ show $ sizeZip z + fromIntegral (BS.length comment))
    ] (streamZip z comment)

zipResponse2 :: BS.ByteString -> ZIP.ZipArchive () -> ActionM Response
zipResponse2 n zipAddActions = do
  req <- peek
  u <- peek
  let comment = BSL.toStrict $ BSB.toLazyByteString
        $ BSB.string8 "Downloaded by " <> TE.encodeUtf8Builder (partyName $ partyRow u) <> BSB.string8 " <" <> actionURL (Just req) viewParty (HTML, TargetParty $ partyId $ partyRow u) [] <> BSB.char8 '>'
  let temporaryZipName = "/tmp/placeholder.zip" -- TODO: generate temporary name for extra caution?
  h <- liftIO $ IO.openFile temporaryZipName IO.ReadWriteMode
  liftIO $ DIR.removeFile temporaryZipName
  liftIO $ IO.hSetBinaryMode h True
  liftIO $ ZIP.createBlindArchive h $ do
    ZIP.setArchiveComment (TE.decodeUtf8 comment)
    -- TODO: set compression level/alg?
    zipAddActions
  sz <- liftIO $ (IO.hSeek h IO.SeekFromEnd 0 >> IO.hTell h)
  liftIO $ IO.hSeek h IO.AbsoluteSeek 0
  return $ okResponse
    [ (hContentType, "application/zip")
{'fraction_non_alphanumeric': 0.09914693074032095, 'fraction_numerical': 0.003161725228181113, 'mean_word_length': 3.8034383954154727, 'pattern_counts': {'":': 0, '<': 82, '<?xml version=': 0, '>': 100, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 24, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1177597', 'n_tokens_mistral': 5346, 'n_tokens_neox': 5015, 'n_words': 1572}