1 {-# LANGUAGE OverloadedStrings #-} 2 module Databrary.Controller.Slot 3 ( getSlot 4 , viewSlot 5 , slotDownloadName 6 , thumbSlot 7 ) where 8 9 import Control.Monad (when, mfilter) 10 import qualified Data.ByteString as BS 11 import qualified Data.ByteString.Char8 as BSC 12 import Data.Maybe (isJust) 13 import Data.Monoid ((<>)) 14 import qualified Data.Text as T 15 import Network.HTTP.Types.Status (movedPermanently301) 16 import qualified Network.Wai as Wai 17 18 import Databrary.Has (view, peeks) 19 import qualified Databrary.JSON as JSON 20 import Databrary.Model.Id 21 import Databrary.Model.Permission 22 import Databrary.Model.Volume 23 import Databrary.Model.Container 24 import Databrary.Model.Slot 25 import Databrary.Model.Asset 26 import Databrary.Model.AssetSlot 27 import Databrary.Model.AssetSegment 28 import Databrary.Model.Excerpt 29 import Databrary.Model.Record 30 import Databrary.Model.RecordSlot 31 import Databrary.Model.Tag 32 import Databrary.Model.Comment 33 import Databrary.Store.Filename 34 import Databrary.HTTP.Path.Parser 35 import Databrary.Action 36 import Databrary.Controller.Paths 37 import Databrary.Controller.Permission 38 import Databrary.Controller.Angular 39 import Databrary.Controller.Container 40 import Databrary.Controller.Volume (volumeIsPublicRestricted) 41 import Databrary.Controller.Web 42 import {-# SOURCE #-} Databrary.Controller.AssetSegment 43 44 getSlot :: Permission -> Maybe (Id Volume) -> Id Slot -> Handler Slot 45 getSlot p mv i = 46 checkPermission p =<< maybeAction . maybe id (\v -> mfilter $ (v ==) . view) mv =<< lookupSlot i 47 48 slotJSONField :: Bool -> Slot -> BS.ByteString -> Maybe BS.ByteString -> Handler (Maybe JSON.Encoding) 49 slotJSONField getOrig o "assets" _ = 50 case getOrig of 51 True -> Just . JSON.mapRecords (assetSlotJSON False) <$> lookupOrigSlotAssets o -- public restricted consult volume soon 52 False -> Just . JSON.mapRecords (assetSlotJSON False) <$> lookupSlotAssets o 53 slotJSONField _ o "records" _ = -- recordJSON should decide public restricted based on volume 54 Just . JSON.mapRecords 55 (\r -> 56 recordSlotJSON False r `JSON.foldObjectIntoRec` ("record" JSON..=: recordJSON False (slotRecord r))) <$> lookupSlotRecords o 57 slotJSONField _ o "tags" n = do 58 tc <- lookupSlotTagCoverage o (maybe 64 fst $ BSC.readInt =<< n) 59 return $ Just $ JSON.pairs $ JSON.recordMap $ map tagCoverageJSON tc 60 slotJSONField _ o "comments" n = do 61 c <- lookupSlotComments o (maybe 64 fst $ BSC.readInt =<< n) 62 return $ Just $ JSON.mapRecords commentJSON c 63 slotJSONField _ o "excerpts" _ = 64 Just . JSON.mapObjects (\e -> excerptJSON e <> "asset" JSON..= (view e :: Id Asset)) <$> lookupSlotExcerpts o 65 slotJSONField _ o "filename" _ = 66 return $ Just $ JSON.toEncoding $ makeFilename $ slotDownloadName o 67 slotJSONField _ _ _ _ = return Nothing 68 69 slotJSONQuery :: Bool -> Slot -> JSON.Query -> Handler (JSON.Record (Id Container) JSON.Series) 70 slotJSONQuery origQ o q = (slotJSON o `JSON.foldObjectIntoRec`) <$> JSON.jsonQuery (slotJSONField origQ o) q 71 72 slotDownloadName :: Slot -> [T.Text] 73 slotDownloadName s = containerDownloadName (slotContainer s) 74 75 viewSlot :: Bool -> ActionRoute (API, (Maybe (Id Volume), Id Slot)) 76 viewSlot viewOrig = action GET (pathAPI </> pathMaybe pathId </> pathSlotId) $ \(api, (vi, i)) -> withAuth $ do 77 when (api == HTML && isJust vi) angular 78 c <- getSlot PermissionPUBLIC vi i 79 let v = (containerVolume . slotContainer) c 80 _ <- maybeAction (if volumeIsPublicRestricted v then Nothing else Just ()) -- block if restricted 81 case api of 82 JSON -> okResponse [] <$> (slotJSONQuery viewOrig c =<< peeks Wai.queryString) 83 HTML 84 | isJust vi -> return $ okResponse [] $ BSC.pack $ show $ containerId $ containerRow $ slotContainer c 85 | otherwise -> peeks $ redirectRouteResponse movedPermanently301 [] (viewSlot viewOrig) (api, (Just (view c), slotId c)) 86 87 thumbSlot :: ActionRoute (Maybe (Id Volume), Id Slot) 88 thumbSlot = action GET (pathMaybe pathId </> pathSlotId </< "thumb") $ \(vi, i) -> withAuth $ do 89 s <- getSlot PermissionPUBLIC vi i 90 let v = (containerVolume . slotContainer) s 91 _ <- maybeAction (if volumeIsPublicRestricted v then Nothing else Just ()) -- block if restricted, duplicated from above 92 e <- lookupSlotSegmentThumb s 93 maybe 94 (peeks $ otherRouteResponse [] webFile (Just $ staticPath ["images", "draft.png"])) 95 (\as -> peeks $ otherRouteResponse [] downloadAssetSegment (slotId $ view as, assetId $ assetRow $ view as)) 96 e