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