1 {-# LANGUAGE OverloadedStrings #-} 2 module Databrary.Controller.Asset 3 ( getAsset 4 -- , getOrigAsset 5 , assetJSONField 6 , viewAsset 7 , AssetTarget(..) 8 , postAsset 9 -- , viewAssetEdit 10 , createAsset 11 -- , viewAssetCreate 12 , createSlotAsset 13 -- , viewSlotAssetCreate 14 , deleteAsset 15 , downloadAsset 16 , downloadOrigAsset 17 , thumbAsset 18 , assetDownloadName 19 ) where 20 21 import Control.Applicative ((<|>)) 22 import Control.Monad ((<=<), void, guard, when) 23 import Control.Monad.Trans.Class (lift) 24 import qualified Data.ByteString as BS 25 import Data.Maybe (fromMaybe, isNothing, isJust, maybeToList) 26 import Data.Monoid ((<>)) 27 import qualified Data.Text as T 28 import qualified Data.Text.Encoding as TE 29 import qualified Database.PostgreSQL.Typed.Range as Range 30 import Network.HTTP.Types (conflict409) 31 import qualified Network.Wai as Wai 32 import Network.Wai.Parse (FileInfo(..)) 33 import qualified System.FilePath.Posix as FPP (makeValid) 34 import qualified System.FilePath.Windows as FPW (makeValid) 35 36 import Databrary.Ops 37 import Databrary.Has 38 import qualified Databrary.JSON as JSON 39 import Databrary.Model.Segment 40 import Databrary.Model.Permission 41 import Databrary.Model.Release 42 import Databrary.Model.Id 43 import Databrary.Model.Volume 44 import Databrary.Model.Container 45 import Databrary.Model.Token 46 import Databrary.Model.Format 47 import Databrary.Model.Asset 48 import Databrary.Model.Slot 49 import Databrary.Model.AssetSlot 50 import Databrary.Model.AssetSegment 51 import Databrary.Model.Excerpt 52 import Databrary.Model.AssetRevision 53 import Databrary.Model.Transcode 54 import Databrary.Model.Notification 55 import Databrary.Files hiding ((</>)) 56 import Databrary.Store.Types 57 import Databrary.Store.Asset 58 import Databrary.Store.Upload 59 import Databrary.Store.Temp 60 import Databrary.Store.Transcode 61 import Databrary.Store.AV (avProbeLength) 62 import Databrary.Store.Probe 63 import Databrary.HTTP.Request 64 import Databrary.HTTP.Form.Errors 65 import Databrary.HTTP.Form.Deform 66 import Databrary.HTTP.Path.Parser 67 import Databrary.Action 68 import Databrary.Controller.Paths 69 import Databrary.Controller.Permission 70 import Databrary.Controller.Form 71 import Databrary.Controller.Volume 72 import Databrary.Controller.Slot 73 import Databrary.Controller.Format 74 import Databrary.Controller.Notification 75 import {-# SOURCE #-} Databrary.Controller.AssetSegment 76 -- import Databrary.View.Asset 77 import Databrary.View.Form (FormHtml) 78 79 import Control.Monad.IO.Class 80 81 getAsset :: Bool -> Permission -> Bool -> Id Asset -> Handler AssetSlot 82 getAsset getOrig p checkDataPerm i = do 83 mAssetSlot <- (if getOrig then lookupOrigAssetSlot else lookupAssetSlot) i 84 slot <- maybeAction mAssetSlot 85 void (checkPermission2 (extractPermissionIgnorePolicy . getAssetSlotVolumePermission2) p slot) 86 when checkDataPerm $ do 87 -- TODO: delete 88 liftIO $ print ("checking data perm", "assetSlot", slot) 89 liftIO $ print ("checking data perm", "seg rlses", getAssetSlotRelease2 slot, 90 "vol prm", getAssetSlotVolumePermission2 slot) 91 liftIO $ print ("result perm", dataPermission4 getAssetSlotRelease2 getAssetSlotVolumePermission2 slot) 92 void (userCanReadData getAssetSlotRelease2 getAssetSlotVolumePermission2 slot) 93 pure slot 94 95 assetJSONField :: AssetSlot -> BS.ByteString -> Maybe BS.ByteString -> Handler (Maybe JSON.Encoding) 96 assetJSONField a "container" _ = 97 return $ JSON.recordEncoding . containerJSON False . slotContainer <$> assetSlot a -- containerJSON should consult volume 98 assetJSONField a "creation" _ | ((extractPermissionIgnorePolicy . getAssetSlotVolumePermission2) a) >= PermissionEDIT = do 99 (t, n) <- assetCreation $ slotAsset a 100 return $ Just $ JSON.pairs $ 101 "date" `JSON.kvObjectOrEmpty` t 102 <> "name" `JSON.kvObjectOrEmpty` n 103 assetJSONField a "excerpts" _ = 104 Just . JSON.mapObjects excerptJSON <$> lookupAssetExcerpts a 105 assetJSONField _ _ _ = return Nothing 106 107 assetJSONQuery :: AssetSlot -> JSON.Query -> Handler (JSON.Record (Id Asset) JSON.Series) 108 assetJSONQuery o q = (assetSlotJSON False o `JSON.foldObjectIntoRec`) <$> JSON.jsonQuery (assetJSONField o) q 109 -- public restricted should consult volume 110 111 assetDownloadName :: Bool -> Bool -> AssetRow -> [T.Text] 112 assetDownloadName addPrefix trimFormat a = 113 let 114 assetName' = 115 if trimFormat 116 -- original uploaded files have the extension embedded in the name 117 then fmap (TE.decodeUtf8 . dropFormatExtension (assetFormat a) . TE.encodeUtf8) (assetName a) 118 else assetName a 119 scrubbedAssetName :: Maybe T.Text 120 scrubbedAssetName = 121 fmap scrubAssetName assetName' 122 in 123 if addPrefix 124 then T.pack (show $ assetId a) : maybeToList scrubbedAssetName 125 else maybeToList scrubbedAssetName 126 127 scrubAssetName :: T.Text -> T.Text 128 scrubAssetName = T.pack . FPW.makeValid . FPP.makeValid . T.unpack 129 130 viewAsset :: ActionRoute (API, Id Asset) 131 viewAsset = action GET (pathAPI </> pathId) $ \(api, i) -> withAuth $ do 132 asset <- getAsset False PermissionPUBLIC True i 133 case api of 134 JSON -> okResponse [] <$> (assetJSONQuery asset =<< peeks Wai.queryString) 135 HTML 136 | Just s <- assetSlot asset -> peeks $ otherRouteResponse [] (viewAssetSegment False) (api, Just (view asset), slotId s, assetId $ assetRow $ slotAsset asset) 137 | otherwise -> return $ okResponse [] $ T.pack $ show $ assetId $ assetRow $ slotAsset asset -- TODO 138 139 data AssetTarget 140 = AssetTargetVolume Volume 141 | AssetTargetSlot Slot 142 | AssetTargetAsset AssetSlot 143 144 data FileUploadFile 145 = FileUploadForm (FileInfo TempFile) 146 | FileUploadToken Upload 147 148 fileUploadName :: FileUploadFile -> BS.ByteString 149 fileUploadName (FileUploadForm f) = fileName f 150 fileUploadName (FileUploadToken u) = uploadFilename u 151 152 fileUploadPath :: FileUploadFile -> Storage -> RawFilePath 153 fileUploadPath (FileUploadForm f) _ = tempFilePath $ fileContent f 154 fileUploadPath (FileUploadToken u) s = uploadFile u s 155 156 fileUploadRemove :: FileUploadFile -> Handler () 157 fileUploadRemove (FileUploadForm f) = focusIO $ releaseTempFile $ fileContent f 158 fileUploadRemove (FileUploadToken u) = void $ removeUpload u 159 160 data FileUpload = FileUpload 161 { fileUploadFile :: FileUploadFile 162 , fileUploadProbe :: Probe 163 } 164 165 deformLookup :: (Monad m, Deform f a) => FormErrorMessage -> (a -> m (Maybe b)) -> DeformT f m (Maybe b) 166 deformLookup e l = mapM (deformMaybe' e <=< lift . l) =<< deformNonEmpty deform 167 168 detectUpload :: FileUploadFile -> DeformHandler TempFile FileUpload 169 detectUpload u = do 170 liftIO $ print "detectUpload..." 171 either deformError' (return . FileUpload u) 172 =<< lift (probeFile (fileUploadName u) =<< peeks (fileUploadPath u)) 173 174 processAsset :: AssetTarget -> Handler Response 175 processAsset target = do 176 let as@AssetSlot{ slotAsset = a, assetSlot = s } = case target of 177 AssetTargetVolume t -> assetNoSlot $ blankAsset t 178 AssetTargetSlot t -> AssetSlot (blankAsset (view t)) (Just t) 179 AssetTargetAsset t -> t 180 (as', up') <- runFormFiles [("file", maxAssetSize)] (Nothing :: Maybe (RequestContext -> FormHtml a)) $ do 181 liftIO $ putStrLn "runFormFiles..."--DEBUG 182 csrfForm 183 (file :: Maybe (FileInfo TempFile)) <- "file" .:> deform 184 liftIO $ putStrLn "deformed file..." --DEBUG 185 upload <- "upload" .:> deformLookup "Uploaded file not found." lookupUpload 186 liftIO $ putStrLn "upload file..." --DEBUG 187 upfile <- case (file, upload) of 188 (Just f, Nothing) -> return $ Just $ FileUploadForm f 189 (Nothing, Just u) -> return $ Just $ FileUploadToken u 190 (Nothing, Nothing) 191 | AssetTargetAsset _ <- target -> return Nothing 192 | otherwise -> Nothing <$ deformError "File or upload required." 193 _ -> Nothing <$ deformError "Conflicting uploaded files found." 194 up <- mapM detectUpload upfile 195 liftIO $ putStrLn "upfile cased..." --DEBUG 196 let fmt = maybe (assetFormat $ assetRow a) (probeFormat . fileUploadProbe) up 197 liftIO $ putStrLn "format upload probe..." --DEBUG 198 name <- "name" .:> maybe (assetName $ assetRow a) (TE.decodeUtf8 . dropFormatExtension fmt <$>) <$> deformOptional (deformNonEmpty deform) 199 liftIO $ putStrLn "renamed asset..." --DEBUG 200 classification <- "classification" .:> fromMaybe (assetRelease $ assetRow a) <$> deformOptional (deformNonEmpty deform) 201 liftIO $ putStrLn "classification deformed..." --DEBUG 202 slot <- 203 "container" .:> (<|> slotContainer <$> s) <$> deformLookup "Container not found." (lookupVolumeContainer (assetVolume a)) 204 >>= mapM (\c -> "position" .:> do 205 let seg = slotSegment <$> s 206 dur = maybe (assetDuration $ assetRow a) (probeLength . fileUploadProbe) up 207 p <- fromMaybe (lowerBound . segmentRange =<< seg) <$> deformOptional (deformNonEmpty deform) 208 Slot c . maybe fullSegment 209 (\l -> Segment $ Range.bounded l (l + fromMaybe 0 ((segmentLength =<< seg) <|> dur))) 210 <$> orElseM p (mapM (lift . probeAutoPosition c . Just . fileUploadProbe) (guard (isNothing s && isJust dur) >> up))) 211 liftIO $ putStrLn "slot assigned..." --DEBUG 212 return 213 ( as 214 { slotAsset = a 215 { assetRow = (assetRow a) 216 { assetName = name 217 , assetRelease = classification 218 , assetFormat = fmt 219 } 220 } 221 , assetSlot = slot 222 } 223 , up 224 ) 225 as'' <- maybe (return as') (\up@FileUpload{ fileUploadFile = upfile } -> do 226 a' <- addAsset (slotAsset as') 227 { assetRow = (assetRow $ slotAsset as') 228 { assetName = Just $ TE.decodeUtf8 $ fileUploadName upfile 229 , assetDuration = Nothing 230 , assetSize = Nothing 231 , assetSHA1 = Nothing 232 } 233 } . Just =<< peeks (fileUploadPath upfile) 234 fileUploadRemove upfile 235 td <- checkAlreadyTranscoded a' (fileUploadProbe up) 236 te <- peeks transcodeEnabled 237 t <- case fileUploadProbe up of 238 ProbeAV{ probeAV = av } | td -> 239 return a'{ assetRow = (assetRow a'){ assetDuration = avProbeLength av } } 240 probe@ProbeAV{} | te -> do 241 t <- addTranscode a' fullSegment defaultTranscodeOptions probe 242 _ <- forkTranscode t 243 return $ transcodeAsset t 244 _ -> return a' 245 case target of 246 AssetTargetAsset _ -> replaceAsset a t 247 _ -> return () 248 return $ fixAssetSlotDuration as' 249 { slotAsset = t 250 { assetRow = (assetRow t) 251 { assetName = assetName $ assetRow $ slotAsset as' 252 } 253 } 254 }) 255 up' 256 a' <- changeAsset (slotAsset as'') Nothing 257 liftIO $ putStrLn "changed asset..." --DEBUG 258 _ <- changeAssetSlot as'' 259 liftIO $ putStrLn "change asset slot..." --DEBUG 260 when (assetRelease (assetRow a') == Just ReleasePUBLIC && assetRelease (assetRow a) /= Just ReleasePUBLIC) $ 261 createVolumeNotification (assetVolume a') $ \n -> (n NoticeReleaseAsset) 262 { notificationContainerId = containerId . containerRow . slotContainer <$> assetSlot as'' 263 , notificationSegment = slotSegment <$> assetSlot as'' 264 , notificationAssetId = Just $ assetId $ assetRow a' 265 , notificationRelease = assetRelease $ assetRow a' 266 } 267 (do 268 liftIO $ putStrLn "JSON ok response..." --DEBUG 269 return $ okResponse [] $ JSON.recordEncoding $ assetSlotJSON False as'') -- publicrestrict false because EDIT 270 -- HTML -> do 271 -- liftIO $ putStrLn "returning HTML other route reponse..." --DEBUG 272 -- peeks $ otherRouteResponse [] viewAsset (api, assetId $ assetRow $ slotAsset as'') 273 274 postAsset :: ActionRoute (Id Asset) 275 postAsset = multipartAction $ action POST (pathJSON >/> pathId) $ \(ai) -> withAuth $ do 276 asset <- getAsset False PermissionEDIT False ai 277 r <- assetIsReplaced (slotAsset asset) 278 when r $ result $ 279 response conflict409 [] ("This file has already been replaced." :: T.Text) 280 processAsset $ AssetTargetAsset asset 281 282 {- 283 viewAssetEdit :: ActionRoute (Id Asset) 284 viewAssetEdit = action GET (pathHTML >/> pathId </< "edit") $ \ai -> withAuth $ do 285 asset <- getAsset False PermissionEDIT False ai 286 peeks $ blankForm . htmlAssetEdit (AssetTargetAsset asset) 287 -} 288 289 createAsset :: ActionRoute (Id Volume) 290 createAsset = multipartAction $ action POST (pathJSON >/> pathId </< "asset") $ \vi -> withAuth $ do 291 liftIO $ print "getting volume permission..." 292 v <- getVolume PermissionEDIT vi 293 liftIO $ print "processing asset..." 294 processAsset $ AssetTargetVolume v 295 296 {- 297 viewAssetCreate :: ActionRoute (Id Volume) 298 viewAssetCreate = action GET (pathHTML >/> pathId </< "asset") $ \vi -> withAuth $ do 299 v <- getVolume PermissionEDIT vi 300 peeks $ blankForm . htmlAssetEdit (AssetTargetVolume v) 301 -} 302 303 createSlotAsset :: ActionRoute (Id Slot) 304 createSlotAsset = multipartAction $ action POST (pathJSON >/> pathSlotId </< "asset") $ \(si) -> withAuth $ do 305 v <- getSlot PermissionEDIT Nothing si 306 processAsset $ AssetTargetSlot v 307 308 {- 309 viewSlotAssetCreate :: ActionRoute (Id Slot) 310 viewSlotAssetCreate = action GET (pathHTML >/> pathSlotId </< "asset") $ \si -> withAuth $ do 311 s <- getSlot PermissionEDIT Nothing si 312 peeks $ blankForm . htmlAssetEdit (AssetTargetSlot s) 313 -} 314 315 deleteAsset :: ActionRoute (Id Asset) 316 deleteAsset = action DELETE (pathJSON >/> pathId) $ \ai -> withAuth $ do 317 guardVerfHeader 318 asset <- getAsset False PermissionEDIT False ai 319 let asset' = asset{ assetSlot = Nothing } 320 _ <- changeAssetSlot asset' 321 return $ okResponse [] $ JSON.recordEncoding $ assetSlotJSON False asset' -- publicRestricted false because EDIT 322 -- HTML -> peeks $ otherRouteResponse [] viewAsset (api, assetId $ assetRow $ slotAsset asset') 323 324 downloadAsset :: ActionRoute (Id Asset, Segment) 325 downloadAsset = action GET (pathId </> pathSegment </< "download") $ \(ai, seg) -> withAuth $ do 326 a <- getAsset False PermissionPUBLIC True ai 327 inline <- peeks $ lookupQueryParameters "inline" 328 serveAssetSegment (null inline) $ newAssetSegment a seg Nothing 329 330 downloadOrigAsset :: ActionRoute (Id Asset, Segment) 331 downloadOrigAsset = action GET (pathId </> pathSegment </< "downloadOrig") $ \(ai, seg) -> withAuth $ do 332 a <- getAsset True PermissionPUBLIC True ai 333 inline <- peeks $ lookupQueryParameters "inline" 334 serveAssetSegment (null inline) $ newAssetSegment a seg Nothing 335 336 thumbAsset :: ActionRoute (Id Asset, Segment) 337 thumbAsset = action GET (pathId </> pathSegment </< "thumb") $ \(ai, seg) -> withAuth $ do 338 a <- getAsset False PermissionPUBLIC False ai 339 let as = assetSegmentInterp 0.25 $ newAssetSegment a seg Nothing 340 if formatIsImage (view as) 341 && assetBacked (view as) 342 && canReadData2 getAssetSegmentRelease2 getAssetSegmentVolumePermission2 as 343 then peeks $ otherRouteResponse [] downloadAsset (view as, assetSegment as) 344 else peeks $ otherRouteResponse [] formatIcon (view as)