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)