1 {-# LANGUAGE OverloadedStrings, TupleSections, ScopedTypeVariables #-}
    2 module Databrary.Controller.AssetSegment
    3   ( getAssetSegment
    4   , viewAssetSegment
    5   , serveAssetSegment
    6   , downloadAssetSegment
    7   , downloadOrigAssetSegment
    8   , thumbAssetSegment
    9   ) where
   10 
   11 import Control.Monad ((<=<), join, when, mfilter, void)
   12 import Control.Monad.IO.Class (liftIO)
   13 import qualified Data.ByteString as BS
   14 import qualified Data.ByteString.Builder as BSB
   15 import qualified Data.ByteString.Char8 as BSC
   16 import qualified Data.ByteString.Lazy as BSL
   17 import Data.Maybe (isJust, fromJust, listToMaybe)
   18 import Data.Monoid ((<>))
   19 import qualified Data.Text as T
   20 import Network.HTTP.Types (ResponseHeaders)
   21 import Network.HTTP.Types.Status (movedPermanently301)
   22 import qualified Network.Wai as Wai
   23 import Text.Read (readMaybe)
   24 import System.Posix.Types (FileOffset)
   25 
   26 import Databrary.Files (unRawFilePath, RawFilePath)
   27 import Databrary.Ops
   28 import Databrary.Has (view, peeks)
   29 import qualified Databrary.JSON as JSON
   30 import Databrary.Files (fileInfo)
   31 import Databrary.Model.Id
   32 import Databrary.Model.Permission
   33 import Databrary.Model.Volume
   34 import Databrary.Model.Slot
   35 import Databrary.Model.Format
   36 import Databrary.Model.Asset
   37 import Databrary.Model.AssetSlot
   38 import Databrary.Model.AssetSegment
   39 import Databrary.Store.Asset
   40 import Databrary.Store.AssetSegment
   41 import Databrary.Store.Filename
   42 import Databrary.HTTP.File
   43 import Databrary.HTTP.Request
   44 import Databrary.HTTP.Path.Parser
   45 import Databrary.Action
   46 import Databrary.Controller.Paths
   47 import Databrary.Controller.Angular
   48 import Databrary.Controller.Permission
   49 import Databrary.Controller.Volume
   50 import Databrary.Controller.Slot
   51 import Databrary.Controller.Asset
   52 import Databrary.Controller.Format
   53 
   54 -- Boolean flag to toggle the choice of downloading the original asset file.
   55 getAssetSegment :: Bool -> Permission -> Bool -> Maybe (Id Volume) -> Id Slot -> Id Asset -> Handler AssetSegment
   56 getAssetSegment getOrig p checkDataPerm mv s a = do
   57   mAssetSeg <- (if getOrig then lookupOrigSlotAssetSegment else lookupSlotAssetSegment) s a
   58   assetSeg <- maybeAction ((maybe id (\v -> mfilter $ (v ==) . view) mv) mAssetSeg)
   59   void (checkPermission2 (extractPermissionIgnorePolicy . getAssetSegmentVolumePermission2) p assetSeg)
   60   when checkDataPerm $ do
   61     -- TODO: delete
   62     -- liftIO $ print ("checking data perm", "as", assetSeg)
   63     -- liftIO $ print ("checking data perm", "seg rlses", getAssetSegmentRelease2 assetSeg,
   64     --                 "vol prm", getAssetSegmentVolumePermission2 assetSeg)
   65     -- liftIO $ print ("result perm", dataPermission4 getAssetSegmentRelease2 getAssetSegmentVolumePermission2 assetSeg)
   66     void (userCanReadData getAssetSegmentRelease2 getAssetSegmentVolumePermission2 assetSeg)
   67   pure assetSeg
   68 
   69 assetSegmentJSONField :: AssetSegment -> BS.ByteString -> Maybe BS.ByteString -> Handler (Maybe JSON.Encoding)
   70 assetSegmentJSONField a "asset" _ = return $ Just $ JSON.recordEncoding $ assetSlotJSON False (segmentAsset a)
   71 assetSegmentJSONField a v o = assetJSONField (segmentAsset a) v o
   72 -- publicRestricted should consult volume
   73 
   74 assetSegmentJSONQuery :: AssetSegment -> JSON.Query -> Handler JSON.Series
   75 assetSegmentJSONQuery o q = (assetSegmentJSON o <>) <$> JSON.jsonQuery (assetSegmentJSONField o) q
   76 
   77 assetSegmentDownloadName :: AssetSegment -> [T.Text]
   78 assetSegmentDownloadName a =
   79      volumeDownloadName (view a)
   80   ++ foldMap slotDownloadName (assetSlot $ segmentAsset a)
   81   ++ assetDownloadName True False (assetRow $ view a)
   82 
   83 viewAssetSegment :: Bool -> ActionRoute (API, Maybe (Id Volume), Id Slot, Id Asset)
   84 viewAssetSegment getOrig = action GET (pathAPI </>>> pathMaybe pathId </>> pathSlotId </> pathId) $ \(api, vi, si, ai) -> withAuth $ do
   85   when (api == HTML && isJust vi) angular
   86   as <- getAssetSegment getOrig PermissionPUBLIC True vi si ai
   87   case api of
   88     JSON -> okResponse [] <$> (assetSegmentJSONQuery as =<< peeks Wai.queryString)
   89     HTML
   90       | isJust vi -> return $ okResponse [] $ T.pack $ show $ assetId $ assetRow $ slotAsset $ segmentAsset as
   91       | otherwise -> peeks $ redirectRouteResponse movedPermanently301 [] (viewAssetSegment getOrig) (api, Just (view as), slotId $ view as, view as)
   92 
   93 serveAssetSegment :: Bool -> AssetSegment -> Handler Response
   94 serveAssetSegment dl as = do
   95   -- liftIO $ print ("download?", dl)
   96   -- liftIO $ print ("asset seg?", as)
   97   sz <- peeks $ readMaybe . BSC.unpack <=< join . listToMaybe . lookupQueryParameters "size"
   98   -- liftIO $ print ("determined size", sz)
   99   when dl $ auditAssetSegmentDownload True as
  100   store :: RawFilePath <- maybeAction =<< getAssetFile a
  101   (hd :: ResponseHeaders, part :: Maybe FileOffset) <-
  102     fileResponse
  103       store
  104       (view as :: Format)
  105       (dl `thenUse` (makeFilename (assetSegmentDownloadName as)) :: Maybe BS.ByteString) -- download file name
  106       (BSL.toStrict $ BSB.toLazyByteString $  -- etag for http serve
  107         BSB.byteStringHex (fromJust $ assetSHA1 $ assetRow a) <> BSB.string8 (assetSegmentTag as sz)
  108         :: BS.ByteString)
  109   (eStreamRunnerOrFile :: Either ((BS.ByteString -> IO ()) -> IO ()) RawFilePath) <- getAssetSegmentStore as sz
  110   either
  111     (return . okResponse hd)
  112     (\f -> do
  113       Just (z, _) <- liftIO $ fileInfo f
  114       fp <- liftIO $ unRawFilePath f
  115       return $ okResponse hd (fp, z <$ part))
  116     eStreamRunnerOrFile
  117   where
  118   a = slotAsset $ segmentAsset as
  119 
  120 downloadAssetSegment :: ActionRoute (Id Slot, Id Asset)
  121 downloadAssetSegment = action GET (pathSlotId </> pathId </< "download") $ \(si, ai) -> withAuth $ do
  122   as <- getAssetSegment False PermissionPUBLIC True Nothing si ai
  123   inline <- peeks $ boolQueryParameter "inline"
  124   serveAssetSegment (not inline) as
  125 
  126 downloadOrigAssetSegment :: ActionRoute (Id Slot, Id Asset)
  127 downloadOrigAssetSegment = action GET (pathSlotId </> pathId </< "downloadOrig") $ \(si, ai) -> withAuth $ do
  128   as <- getAssetSegment True PermissionPUBLIC True Nothing si ai
  129   inline <- peeks $ boolQueryParameter "inline"
  130   serveAssetSegment (not inline) as
  131 
  132 
  133 thumbAssetSegment :: Bool -> ActionRoute (Id Slot, Id Asset)
  134 thumbAssetSegment getOrig = action GET (pathSlotId </> pathId </< "thumb") $ \(si, ai) -> withAuth $ do
  135   as <- getAssetSegment getOrig PermissionPUBLIC False Nothing si ai  -- why checkDataPerm == False?
  136   let as' = assetSegmentInterp 0.25 as
  137   if formatIsImage (view as')
  138     && assetBacked (view as)
  139     && canReadData2 getAssetSegmentRelease2 getAssetSegmentVolumePermission2 as'
  140     then peeks $ otherRouteResponse [] downloadAssetSegment (slotId $ view as', assetId $ assetRow $ view as')
  141     else peeks $ otherRouteResponse [] formatIcon (view as)