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