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)