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