1 {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
    2 module 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 Files (unRawFilePath, RawFilePath)
   27 import Ops
   28 import Has (view, peeks)
   29 import qualified JSON
   30 import Files (fileInfo)
   31 import Model.Id
   32 import Model.Permission hiding (checkPermission)
   33 import Model.Volume
   34 import Model.Slot
   35 import Model.Format
   36 import Model.Asset
   37 import Model.AssetSlot
   38 import Model.AssetSegment
   39 import Store.Asset
   40 import Store.AssetSegment
   41 import Store.Filename
   42 import HTTP.File
   43 import HTTP.Request
   44 import HTTP.Path.Parser
   45 import Action
   46 import Controller.Paths
   47 import Controller.Angular
   48 import Controller.Permission
   49 import Controller.Volume
   50 import Controller.Slot
   51 import Controller.Asset
   52 import 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 (checkPermission (extractPermissionIgnorePolicy . getAssetSegmentVolumePermission2) p assetSeg)
   60   when checkDataPerm $
   61     void (userCanReadData getAssetSegmentRelease2 getAssetSegmentVolumePermission2 assetSeg)
   62   pure assetSeg
   63 
   64 assetSegmentJSONField :: AssetSegment -> BS.ByteString -> Maybe BS.ByteString -> Handler (Maybe JSON.Encoding)
   65 assetSegmentJSONField a "asset" _ = return $ Just $ JSON.recordEncoding $ assetSlotJSON False (segmentAsset a)
   66 assetSegmentJSONField a v o = assetJSONField (segmentAsset a) v o
   67 -- publicRestricted should consult volume
   68 
   69 assetSegmentJSONQuery :: AssetSegment -> JSON.Query -> Handler JSON.Series
   70 assetSegmentJSONQuery o q = (assetSegmentJSON o <>) <$> JSON.jsonQuery (assetSegmentJSONField o) q
   71 
   72 assetSegmentDownloadName :: AssetSegment -> [T.Text]
   73 assetSegmentDownloadName a =
   74      volumeDownloadName (view a)
   75   ++ foldMap slotDownloadName (assetSlot $ segmentAsset a)
   76   ++ assetDownloadName True False (assetRow $ view a)
   77 
   78 viewAssetSegment :: Bool -> ActionRoute (API, Maybe (Id Volume), Id Slot, Id Asset)
   79 viewAssetSegment getOrig = action GET (pathAPI </>>> pathMaybe pathId </>> pathSlotId </> pathId) $ \(api, vi, si, ai) -> withAuth $ do
   80   when (api == HTML && isJust vi) angular
   81   as <- getAssetSegment getOrig PermissionPUBLIC True vi si ai
   82   case api of
   83     JSON -> okResponse [] <$> (assetSegmentJSONQuery as =<< peeks Wai.queryString)
   84     HTML
   85       | isJust vi -> return $ okResponse [] $ T.pack $ show $ assetId $ assetRow $ slotAsset $ segmentAsset as
   86       | otherwise -> peeks $ redirectRouteResponse movedPermanently301 [] (viewAssetSegment getOrig) (api, Just (view as), slotId $ view as, view as)
   87 
   88 serveAssetSegment :: Bool -> AssetSegment -> Handler Response
   89 serveAssetSegment dl as = do
   90   -- liftIO $ print ("download?", dl)
   91   -- liftIO $ print ("asset seg?", as)
   92   sz <- peeks $ readMaybe . BSC.unpack <=< join . listToMaybe . lookupQueryParameters "size"
   93   -- liftIO $ print ("determined size", sz)
   94   when dl $ auditAssetSegmentDownload True as
   95   store :: RawFilePath <- maybeAction =<< getAssetFile a
   96   (hd :: ResponseHeaders, part :: Maybe FileOffset) <-
   97     fileResponse
   98       store
   99       (view as :: Format)
  100       (dl `thenUse` makeFilename (assetSegmentDownloadName as) :: Maybe BS.ByteString) -- download file name
  101       (BSL.toStrict $ BSB.toLazyByteString $  -- etag for http serve
  102         BSB.byteStringHex (fromJust $ assetSHA1 $ assetRow a) <> BSB.string8 (assetSegmentTag as sz)
  103         :: BS.ByteString)
  104   (eStreamRunnerOrFile :: Either ((BS.ByteString -> IO ()) -> IO ()) RawFilePath) <- getAssetSegmentStore as sz
  105   either
  106     (return . okResponse hd)
  107     (\f -> do
  108       Just (z, _) <- liftIO $ fileInfo f
  109       fp <- liftIO $ unRawFilePath f
  110       return $ okResponse hd (fp, z <$ part))
  111     eStreamRunnerOrFile
  112   where
  113   a = slotAsset $ segmentAsset as
  114 
  115 downloadAssetSegment :: ActionRoute (Id Slot, Id Asset)
  116 downloadAssetSegment = action GET (pathSlotId </> pathId </< "download") $ \(si, ai) -> withAuth $ do
  117   as <- getAssetSegment False PermissionPUBLIC True Nothing si ai
  118   inline <- peeks $ boolQueryParameter "inline"
  119   serveAssetSegment (not inline) as
  120 
  121 downloadOrigAssetSegment :: ActionRoute (Id Slot, Id Asset)
  122 downloadOrigAssetSegment = action GET (pathSlotId </> pathId </< "downloadOrig") $ \(si, ai) -> withAuth $ do
  123   as <- getAssetSegment True PermissionPUBLIC True Nothing si ai
  124   inline <- peeks $ boolQueryParameter "inline"
  125   serveAssetSegment (not inline) as
  126 
  127 
  128 thumbAssetSegment :: Bool -> ActionRoute (Id Slot, Id Asset)
  129 thumbAssetSegment getOrig = action GET (pathSlotId </> pathId </< "thumb") $ \(si, ai) -> withAuth $ do
  130   as <- getAssetSegment getOrig PermissionPUBLIC False Nothing si ai  -- why checkDataPerm == False?
  131   let as' = assetSegmentInterp 0.25 as
  132   if formatIsImage (view as')
  133     && assetBacked (view as)
  134     && canReadData2 getAssetSegmentRelease2 getAssetSegmentVolumePermission2 as'
  135     then peeks $ otherRouteResponse [] downloadAssetSegment (slotId $ view as', assetId $ assetRow $ view as')
  136     else peeks $ otherRouteResponse [] formatIcon (view as)