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