1 {-# LANGUAGE OverloadedStrings #-} 2 module Controller.Slot 3 ( getSlot 4 , getVolumeSlot 5 , viewSlot 6 , slotDownloadName 7 , thumbSlot 8 ) where 9 10 import Control.Monad (when) 11 import Data.Maybe (isJust) 12 import Data.Monoid ((<>)) 13 import Network.HTTP.Types.Status (movedPermanently301) 14 import qualified Data.ByteString as BS 15 import qualified Data.ByteString.Char8 as BSC 16 import qualified Data.Text as T 17 import qualified Network.Wai as Wai 18 19 import Action 20 import Controller.Angular 21 import {-# SOURCE #-} Controller.AssetSegment 22 import Controller.Container 23 import Controller.Paths 24 import Controller.Volume (volumeIsPublicRestricted) 25 import Controller.Web 26 import HTTP.Path.Parser 27 import Has (view, peeks) 28 import Model.Access 29 import Model.Asset 30 import Model.AssetSegment 31 import Model.AssetSlot 32 import Model.Comment 33 import Model.Container 34 import Model.Excerpt 35 import Model.Id 36 import Model.Permission hiding (checkPermission) 37 import Model.Record 38 import Model.RecordSlot 39 import Model.Slot 40 import Model.Tag 41 import Model.Volume 42 import Store.Filename 43 import qualified JSON 44 45 -- | Convert a 'Slot' into HTTP error responses if the lookup fails or is 46 -- denied. 47 -- 48 -- NOTE: Intentionally implemented exactly like getVolume. Implementations 49 -- should be collected in a single module and merged. 50 getSlot 51 :: Permission 52 -- ^ Requested permission 53 -> Id Slot 54 -- ^ Slot to look up 55 -> Handler Slot 56 -- ^ The slot, as requested (or a short-circuited error response) 57 getSlot requestedPerm sId = do 58 res <- accessSlot requestedPerm sId 59 case res of 60 LookupFailed -> result =<< peeks notFoundResponse 61 AccessDenied -> result =<< peeks forbiddenResponse 62 AccessResult s -> pure s 63 64 -- | Look up a Slot and confirm that it is associated with the given Volume. 65 -- 66 -- This method exists, presumably, so that we can construct urls like 67 -- volume/:volId/slot/:slotId and make sure there's no funny business going on. 68 getVolumeSlot 69 :: Id Volume 70 -- ^ Associated Volume 71 -> Permission 72 -- ^ Requested permission 73 -> Id Slot 74 -- ^ Slot to look up 75 -> Handler Slot 76 -- ^ The slot, as requested (or a short-circuited error response) 77 getVolumeSlot volId requestedPerm sId = do 78 s <- getSlot requestedPerm sId 79 if volumeId (volumeRow (containerVolume (slotContainer s))) == volId 80 then pure s 81 else result =<< peeks notFoundResponse 82 83 slotJSONField 84 :: Bool 85 -> Slot 86 -> BS.ByteString 87 -> Maybe BS.ByteString 88 -> Handler (Maybe JSON.Encoding) 89 slotJSONField getOrig o "assets" _ = case getOrig of 90 True -> 91 Just . JSON.mapRecords (assetSlotJSON False) <$> lookupOrigSlotAssets o -- public restricted consult volume soon 92 False -> 93 Just . JSON.mapRecords (assetSlotJSON False) <$> lookupSlotAssets o 94 slotJSONField _ o "records" _ = -- recordJSON should decide public restricted based on volume 95 Just 96 . JSON.mapRecords 97 (\r -> 98 recordSlotJSON False r 99 `JSON.foldObjectIntoRec` ("record" JSON..=: recordJSON 100 False 101 (slotRecord r) 102 ) 103 ) 104 <$> lookupSlotRecords o 105 slotJSONField _ o "tags" n = do 106 tc <- lookupSlotTagCoverage o (maybe 64 fst $ BSC.readInt =<< n) 107 return $ Just $ JSON.pairs $ JSON.recordMap $ map tagCoverageJSON tc 108 slotJSONField _ o "comments" n = do 109 c <- lookupSlotComments o (maybe 64 fst $ BSC.readInt =<< n) 110 return $ Just $ JSON.mapRecords commentJSON c 111 slotJSONField _ o "excerpts" _ = 112 Just 113 . JSON.mapObjects 114 (\e -> excerptJSON e <> "asset" JSON..= (view e :: Id Asset)) 115 <$> lookupSlotExcerpts o 116 slotJSONField _ o "filename" _ = 117 return $ Just $ JSON.toEncoding $ makeFilename $ slotDownloadName o 118 slotJSONField _ _ _ _ = return Nothing 119 120 slotJSONQuery 121 :: Bool 122 -> Slot 123 -> JSON.Query 124 -> Handler (JSON.Record (Id Container) JSON.Series) 125 slotJSONQuery origQ o q = 126 (slotJSON o `JSON.foldObjectIntoRec`) 127 <$> JSON.jsonQuery (slotJSONField origQ o) q 128 129 slotDownloadName :: Slot -> [T.Text] 130 slotDownloadName s = containerDownloadName (slotContainer s) 131 132 viewSlot :: Bool -> ActionRoute (API, (Maybe (Id Volume), Id Slot)) 133 viewSlot viewOrig = 134 action GET (pathAPI </> pathMaybe pathId </> pathSlotId) 135 $ \(api, (vi, i)) -> withAuth $ do 136 when (api == HTML && isJust vi) angular 137 c <- (maybe getSlot getVolumeSlot vi) PermissionPUBLIC i 138 let v = (containerVolume . slotContainer) c 139 _ <- maybeAction 140 (if volumeIsPublicRestricted v then Nothing else Just ()) -- block if restricted 141 case api of 142 JSON -> 143 okResponse [] 144 <$> (slotJSONQuery viewOrig c =<< peeks Wai.queryString) 145 HTML 146 | isJust vi 147 -> return 148 $ okResponse [] 149 $ BSC.pack 150 $ show 151 $ containerId 152 $ containerRow 153 $ slotContainer c 154 | otherwise 155 -> peeks $ redirectRouteResponse 156 movedPermanently301 157 [] 158 (viewSlot viewOrig) 159 ( api 160 , ( Just 161 ((volumeId 162 . volumeRow 163 . containerVolume 164 . slotContainer 165 ) 166 c 167 ) 168 , slotId c 169 ) 170 ) 171 172 thumbSlot :: ActionRoute (Maybe (Id Volume), Id Slot) 173 thumbSlot = 174 action GET (pathMaybe pathId </> pathSlotId </< "thumb") $ \(vi, i) -> 175 withAuth $ do 176 s <- (maybe getSlot getVolumeSlot vi) PermissionPUBLIC i 177 let v = (containerVolume . slotContainer) s 178 _ <- maybeAction 179 (if volumeIsPublicRestricted v then Nothing else Just ()) -- block if restricted, duplicated from above 180 e <- lookupSlotSegmentThumb s 181 maybe 182 (peeks $ otherRouteResponse 183 [] 184 webFile 185 (Just $ staticPath ["images", "draft.png"]) 186 ) 187 (\as -> peeks $ otherRouteResponse 188 [] 189 downloadAssetSegment 190 (slotId $ view as, assetId $ assetRow $ view as) 191 ) 192 e