1 {-# LANGUAGE OverloadedStrings, TupleSections, ScopedTypeVariables #-} 2 module Databrary.Controller.Volume 3 ( getVolume 4 , viewVolume 5 , viewVolumeEdit 6 , viewVolumeCreateHandler 7 , postVolume 8 , createVolume 9 -- , viewVolumeLinks 10 , postVolumeLinks 11 , postVolumeAssist 12 , queryVolumes 13 , thumbVolume 14 , volumeDownloadName 15 -- , volumeJSONQuery 16 , volumeIsPublicRestricted 17 ) where 18 19 import Control.Applicative ((<|>), optional) 20 import Control.Arrow ((&&&), (***)) 21 import Control.Monad (mfilter, guard, void, when, forM_) 22 -- import Control.Monad.IO.Class (liftIO) 23 import Control.Monad.Trans.Class (lift) 24 import Control.Monad.Trans.State.Lazy (StateT(..), evalStateT, get, put) 25 import qualified Data.ByteString as BS 26 import qualified Data.ByteString.Char8 as BSC 27 import qualified Data.HashMap.Lazy as HML 28 import qualified Data.HashMap.Strict as HM 29 import Data.Function (on) 30 import Data.Maybe (fromMaybe, isNothing) 31 import Data.Monoid ((<>)) 32 import qualified Data.Text as T 33 import qualified Data.Text.Lazy as TL 34 import Network.HTTP.Types (noContent204, unsupportedMediaType415) 35 import qualified Network.Wai as Wai 36 37 import Databrary.Ops 38 import Databrary.Has 39 import qualified Databrary.JSON as JSON 40 import Databrary.Model.Asset (Asset) 41 import Databrary.Model.Enum 42 import Databrary.Model.Id 43 import Databrary.Model.Permission 44 import Databrary.Model.Authorize 45 import Databrary.Model.Volume 46 import Databrary.Model.VolumeAccess 47 import Databrary.Model.Party 48 import Databrary.Model.Citation 49 import Databrary.Model.Citation.CrossRef 50 import Databrary.Model.Funding 51 import Databrary.Model.Container 52 import Databrary.Model.Record 53 import Databrary.Model.VolumeMetric 54 import Databrary.Model.RecordSlot 55 import Databrary.Model.Segment (Segment) 56 import Databrary.Model.Slot 57 import Databrary.Model.AssetSlot 58 import Databrary.Model.Excerpt 59 import Databrary.Model.Tag 60 import Databrary.Model.Comment 61 import Databrary.Model.VolumeState 62 import Databrary.Model.Notification.Types 63 import Databrary.Store.Filename 64 import Databrary.Static.Service 65 import Databrary.Service.Mail 66 import Databrary.HTTP.Parse 67 import Databrary.HTTP.Form.Deform 68 import Databrary.HTTP.Path.Parser 69 import Databrary.Action.Route 70 import Databrary.Action 71 import Databrary.Controller.Paths 72 import Databrary.Controller.Permission 73 import Databrary.Controller.Form 74 import Databrary.Controller.Angular 75 import Databrary.Controller.Web 76 import {-# SOURCE #-} Databrary.Controller.AssetSegment 77 import Databrary.Controller.Notification 78 import Databrary.View.Form (FormHtml) 79 80 getVolume :: Permission -> Id Volume -> Handler Volume 81 getVolume p i = do 82 mVol <- lookupVolume i 83 vol <- maybeAction mVol 84 checkPermission p vol 85 86 data VolumeCache = VolumeCache 87 { volumeCacheAccess :: Maybe [VolumeAccess] 88 , volumeCacheTopContainer :: Maybe Container 89 , volumeCacheRecords :: Maybe (HML.HashMap (Id Record) Record) 90 } 91 92 -- type VolumeCacheHandler a = StateT VolumeCache Handler a 93 94 instance Monoid VolumeCache where 95 mempty = VolumeCache Nothing Nothing Nothing 96 mappend (VolumeCache a1 t1 r1) (VolumeCache a2 t2 r2) = VolumeCache (a1 <|> a2) (t1 <|> t2) (r1 <> r2) 97 98 runVolumeCache :: StateT VolumeCache Handler a -> Handler a 99 runVolumeCache f = evalStateT f mempty 100 101 cacheVolumeAccess :: Volume -> Permission -> StateT VolumeCache Handler [VolumeAccess] 102 cacheVolumeAccess vol perm = do 103 vc <- get 104 takeWhile ((perm <=) . volumeAccessIndividual) <$> 105 fromMaybeM (do 106 a <- lookupVolumeAccess vol PermissionNONE 107 put vc{ volumeCacheAccess = Just a } 108 return a) 109 (volumeCacheAccess vc) 110 111 cacheVolumeRecords :: Volume -> StateT VolumeCache Handler ([Record], HML.HashMap (Id Record) Record) 112 cacheVolumeRecords vol = do 113 vc <- get 114 maybe (do 115 l <- lookupVolumeRecords vol 116 let m = HML.fromList [ (recordId $ recordRow r, r) | r <- l ] 117 put vc{ volumeCacheRecords = Just m } 118 return (l, m)) 119 (return . (HML.elems &&& id)) 120 (volumeCacheRecords vc) 121 122 cacheVolumeTopContainer :: Volume -> StateT VolumeCache Handler Container 123 cacheVolumeTopContainer vol = do 124 vc <- get 125 fromMaybeM (do 126 t <- lookupVolumeTopContainer vol 127 put vc{ volumeCacheTopContainer = Just t } 128 return t) 129 (volumeCacheTopContainer vc) 130 131 leftJoin :: (a -> b -> Bool) -> [a] -> [b] -> [(a, [b])] 132 leftJoin _ [] [] = [] 133 leftJoin _ [] _ = error "leftJoin: leftovers" 134 leftJoin p (a:al) b = uncurry (:) $ (,) a *** leftJoin p al $ span (p a) b 135 136 volumeIsPublicRestricted :: Volume -> Bool 137 volumeIsPublicRestricted v = 138 case volumeRolePolicy v of 139 RolePublicViewer PublicRestrictedPolicy -> True 140 RoleSharedViewer SharedRestrictedPolicy -> True 141 _ -> False 142 143 volumeJSONField :: Volume -> BS.ByteString -> Maybe BS.ByteString -> StateT VolumeCache Handler (Maybe JSON.Encoding) 144 volumeJSONField vol "access" ma = do 145 Just . JSON.mapObjects volumeAccessPartyJSON 146 <$> cacheVolumeAccess vol (fromMaybe PermissionNONE $ readDBEnum . BSC.unpack =<< ma) 147 {- 148 volumeJSONField vol "publicaccess" ma = do 149 Just . JSON.toEncoding . show . volumePublicAccessSummary 150 <$> cacheVolumeAccess vol (fromMaybe PermissionNONE $ readDBEnum . BSC.unpack =<< ma) 151 -} 152 volumeJSONField vol "citation" _ = 153 Just . JSON.toEncoding <$> lookupVolumeCitation vol 154 volumeJSONField vol "links" _ = 155 Just . JSON.toEncoding <$> lookupVolumeLinks vol 156 volumeJSONField vol "funding" _ = 157 Just . JSON.mapObjects fundingJSON <$> lookupVolumeFunding vol 158 volumeJSONField vol "containers" mContainersVal = do 159 (cl :: [((Container, [(Segment, Id Record)]))]) <- if records 160 then lookupVolumeContainersRecordIds vol 161 else nope <$> lookupVolumeContainers vol 162 (cl' :: [((Container, [(Segment, Id Record)]), [(Asset, SlotId)])]) <- if assets 163 then leftJoin (\(c, _) (_, SlotId a _) -> containerId (containerRow c) == a) cl <$> lookupVolumeAssetSlotIds vol 164 else return $ nope cl 165 rm <- if records then snd <$> cacheVolumeRecords vol else return HM.empty 166 let publicRestricted = volumeIsPublicRestricted vol 167 br = blankRecord undefined vol 168 rjs c (s, r) = JSON.recordObject $ (recordSlotJSON publicRestricted) $ RecordSlot (HML.lookupDefault br{ recordRow = (recordRow br){ recordId = r } } r rm) (Slot c s) 169 ajs c (a, SlotId _ s) = JSON.recordObject $ (assetSlotJSON publicRestricted) $ AssetSlot a (Just (Slot c s)) 170 return $ Just $ JSON.mapRecords (\((c, rl), al) -> 171 containerJSON publicRestricted c 172 `JSON.foldObjectIntoRec` 173 ( (if records then JSON.nestObject "records" (\u -> map (u . rjs c) rl) else mempty) 174 <> (if assets then JSON.nestObject "assets" (\u -> map (u . ajs c) al) else mempty))) 175 cl' 176 where 177 full = mContainersVal == Just "all" 178 assets = full || mContainersVal == Just "assets" 179 records = full || mContainersVal == Just "records" 180 nope = map (, []) 181 volumeJSONField vol "top" _ = do 182 topCntr <- cacheVolumeTopContainer vol 183 let publicRestricted = volumeIsPublicRestricted vol 184 (return . Just . JSON.recordEncoding . containerJSON publicRestricted) topCntr 185 volumeJSONField vol "records" _ = do 186 (l, _) <- cacheVolumeRecords vol 187 let publicRestricted = volumeIsPublicRestricted vol 188 return $ Just $ JSON.mapRecords (recordJSON publicRestricted) l 189 volumeJSONField vol "metrics" _ = 190 let metricsCaching = lookupVolumeMetrics vol 191 in (Just . JSON.toEncoding) <$> metricsCaching 192 volumeJSONField vol "excerpts" _ = do 193 Just . JSON.mapObjects (\e -> excerptJSON e 194 <> "asset" JSON..=: (assetSlotJSON False (view e) -- should publicRestricted be set based on volume? 195 `JSON.foldObjectIntoRec` ("container" JSON..= (view e :: Id Container)))) 196 <$> lookupVolumeExcerpts vol 197 volumeJSONField vol "tags" n = do 198 t <- cacheVolumeTopContainer vol 199 tc <- lookupSlotTagCoverage (containerSlot t) (maybe 64 fst $ BSC.readInt =<< n) 200 return $ Just $ JSON.mapRecords tagCoverageJSON tc 201 volumeJSONField vol "comments" n = do 202 t <- cacheVolumeTopContainer vol 203 tc <- lookupSlotComments (containerSlot t) (maybe 64 fst $ BSC.readInt =<< n) 204 return $ Just $ JSON.mapRecords commentJSON tc 205 volumeJSONField vol "state" _ = 206 Just . JSON.toEncoding . JSON.object . map (volumeStateKey &&& volumeStateValue) <$> lookupVolumeState vol 207 volumeJSONField o "filename" _ = 208 return $ Just $ JSON.toEncoding $ makeFilename $ volumeDownloadName o 209 volumeJSONField _ _ _ = return Nothing 210 211 volumeJSONQuery :: Volume -> Maybe [VolumeAccess] -> JSON.Query -> Handler (JSON.Record (Id Volume) JSON.Series) 212 volumeJSONQuery vol mAccesses q = 213 let seriesCaching :: StateT VolumeCache Handler JSON.Series 214 seriesCaching = JSON.jsonQuery (volumeJSONField vol) q 215 expandedVolJSONcaching :: StateT VolumeCache Handler (JSON.Record (Id Volume) JSON.Series) 216 expandedVolJSONcaching = (\series -> volumeJSON vol mAccesses `JSON.foldObjectIntoRec` series) <$> seriesCaching 217 in 218 runVolumeCache $ expandedVolJSONcaching 219 220 volumeDownloadName :: Volume -> [T.Text] 221 volumeDownloadName v = 222 (T.pack $ "databrary" ++ show (volumeId $ volumeRow v)) 223 : map (T.takeWhile (',' /=) . snd) (volumeOwners v) 224 ++ [fromMaybe (volumeName $ volumeRow v) (getVolumeAlias v)] 225 226 viewVolume :: ActionRoute (API, Id Volume) 227 viewVolume = action GET (pathAPI </> pathId) $ \(api, vi) -> withAuth $ do 228 when (api == HTML) angular 229 v <- getVolume PermissionPUBLIC vi 230 accesses <- lookupVolumeAccess v PermissionNONE 231 -- (liftIO . print) ("num accesses", length accesses) 232 -- case api of 233 (let idSeriesRecAct :: Handler (JSON.Record (Id Volume) JSON.Series) 234 idSeriesRecAct = volumeJSONQuery v (Just accesses) =<< peeks Wai.queryString 235 in okResponse [] . JSON.recordEncoding <$> idSeriesRecAct) 236 {- 237 HTML -> do 238 top <- lookupVolumeTopContainer v 239 t <- lookupSlotKeywords $ containerSlot top 240 peeks $ okResponse [] . htmlVolumeView v t 241 -} 242 243 volumeForm :: Volume -> DeformHandler f Volume 244 volumeForm v = do 245 name <- "name" .:> deform 246 alias <- "alias" .:> deformNonEmpty deform 247 body <- "body" .:> deformNonEmpty deform 248 return v 249 { volumeRow = (volumeRow v) 250 { volumeName = name 251 , volumeAlias = alias 252 , volumeBody = body 253 } 254 } 255 256 -- FIXME: Too impure, and needs test: What elements of the input are modified? 257 volumeCitationForm :: Volume -> DeformHandler f (Volume, Maybe Citation) 258 volumeCitationForm v = do 259 csrfForm 260 vol <- volumeForm v 261 cite <- "citation" .:> Citation 262 <$> ("head" .:> deform) 263 <*> ("url" .:> deformNonEmpty deform) 264 <*> ("year" .:> deformNonEmpty deform) 265 <*> pure Nothing 266 look <- flatMapM (lift . focusIO . lookupCitation) $ 267 guard (T.null (volumeName $ volumeRow vol) || T.null (citationHead cite) || isNothing (citationYear cite)) >> citationURL cite 268 let fill = maybe cite (cite <>) look 269 empty = T.null (citationHead fill) && isNothing (citationURL fill) && isNothing (citationYear fill) 270 name 271 | Just title <- citationTitle fill 272 , T.null (volumeName $ volumeRow vol) = title 273 | otherwise = volumeName $ volumeRow vol 274 _ <- "name" .:> deformRequired name 275 when (not empty) $ void $ 276 "citation" .:> "head" .:> deformRequired (citationHead fill) 277 return (vol{ volumeRow = (volumeRow vol){ volumeName = name } }, empty `unlessUse` fill) 278 279 viewVolumeEdit :: ActionRoute (Id Volume) 280 viewVolumeEdit = action GET (pathHTML >/> pathId </< "edit") $ \_ -> withAuth $ do 281 angular 282 return (okResponse [] ("" :: String)) -- should never get here 283 {- 284 v <- getVolume PermissionEDIT vi 285 cite <- lookupVolumeCitation v 286 peeks $ blankForm . htmlVolumeEdit (Just (v, cite)) -} 287 288 viewVolumeCreateHandler :: Action -- TODO : GET only 289 viewVolumeCreateHandler = withAuth $ do 290 angular 291 return (okResponse [] ("" :: String)) -- should never get here 292 -- peeks $ blankForm . htmlVolumeEdit Nothing 293 294 postVolume :: ActionRoute (Id Volume) 295 postVolume = action POST (pathJSON >/> pathId) $ \vi -> withAuth $ do 296 v <- getVolume PermissionEDIT vi 297 cite <- lookupVolumeCitation v 298 (v', cite') <- runForm (Nothing :: Maybe (RequestContext -> FormHtml a)) $ volumeCitationForm v 299 changeVolume v' 300 r <- changeVolumeCitation v' cite' 301 return $ okResponse [] $ 302 JSON.recordEncoding $ volumeJSONSimple v' `JSON.foldObjectIntoRec` ("citation" JSON..= if r then cite' else cite) 303 -- HTML -> peeks $ otherRouteResponse [] viewVolume arg 304 305 createVolume :: ActionRoute () 306 createVolume = action POST (pathJSON >/> "volume") $ \() -> withAuth $ do 307 u <- peek 308 (bv, cite, owner) <- runForm (Nothing :: Maybe (RequestContext -> FormHtml a)) $ do 309 csrfForm 310 (bv, cite) <- volumeCitationForm blankVolume 311 own <- "owner" .:> do 312 oi <- deformOptional deform 313 own <- maybe (return $ Just $ selfAuthorize u) (lift . lookupAuthorizeParent u) $ mfilter (partyId (partyRow u) /=) oi 314 deformMaybe' "You are not authorized to create volumes for that owner." $ 315 authorizeParent . authorization <$> mfilter ((PermissionADMIN <=) . accessMember) own 316 auth <- lift $ lookupAuthorization own rootParty 317 deformGuard "Insufficient site authorization to create volume." $ 318 PermissionEDIT <= accessSite auth 319 return (bv, cite, own) 320 v <- addVolume bv 321 _ <- changeVolumeCitation v cite 322 setDefaultVolumeAccessesForCreated owner v 323 when (on (/=) (partyId . partyRow) owner u) $ forM_ (partyAccount owner) $ \t -> 324 createNotification (blankNotification t NoticeVolumeCreated) 325 { notificationVolume = Just $ volumeRow v 326 , notificationParty = Just $ partyRow owner 327 } 328 return $ okResponse [] $ JSON.recordEncoding $ volumeJSONSimple v 329 -- HTML -> peeks $ otherRouteResponse [] viewVolume (api, volumeId $ volumeRow v) 330 331 {- 332 viewVolumeLinks :: ActionRoute (Id Volume) 333 viewVolumeLinks = action GET (pathHTML >/> pathId </< "link") $ \vi -> withAuth $ do 334 v <- getVolume PermissionEDIT vi 335 links <- lookupVolumeLinks v 336 peeks $ blankForm . htmlVolumeLinksEdit v links 337 -} 338 339 postVolumeLinks :: ActionRoute (Id Volume) 340 postVolumeLinks = action POST (pathJSON >/> pathId </< "link") $ \vi -> withAuth $ do 341 v <- getVolume PermissionEDIT vi 342 -- links <- lookupVolumeLinks v 343 links' <- runForm (Nothing :: Maybe (RequestContext -> FormHtml a)) $ do 344 csrfForm 345 withSubDeforms $ \_ -> Citation 346 <$> ("head" .:> deform) 347 <*> ("url" .:> (Just <$> deform)) 348 <*> pure Nothing 349 <*> pure Nothing 350 changeVolumeLinks v links' 351 return $ okResponse [] $ JSON.recordEncoding $ volumeJSONSimple v `JSON.foldObjectIntoRec` ("links" JSON..= links') 352 -- HTML -> peeks $ otherRouteResponse [] viewVolume arg 353 354 postVolumeAssist :: ActionRoute (Id Volume) 355 postVolumeAssist = action POST (pathJSON >/> pathId </< "assist") $ \vi -> withAuth $ do 356 user <- authAccount 357 v <- getVolume PermissionEDIT vi 358 addr <- peeks staticAssistAddr 359 cont <- parseRequestContent (const 0) 360 body <- case cont :: Content () of 361 ContentText body -> return body 362 _ -> result $ emptyResponse unsupportedMediaType415 [] 363 sendMail [Left addr] [Right user] ("Databrary upload assistance request for volume " <> T.pack (show vi)) $ TL.fromChunks 364 [ partyName $ partyRow $ accountParty user, " has requested curation assistance for ", volumeName $ volumeRow v, "\n\n" ] <> body `TL.snoc` '\n' 365 createVolumeNotification v ($ NoticeVolumeAssist) 366 return $ emptyResponse noContent204 [] 367 368 volumeSearchForm :: DeformHandler f VolumeFilter 369 volumeSearchForm = VolumeFilter 370 <$> ("query" .:> deformNonEmpty deform) 371 <*> ("party" .:> optional deform) 372 <*> paginateForm 373 374 queryVolumes :: ActionRoute API 375 queryVolumes = action GET (pathAPI </< "volume") $ \api -> withAuth $ do 376 when (api == HTML) angular 377 vf <- runForm (Nothing :: Maybe (RequestContext -> FormHtml a)) volumeSearchForm 378 p <- findVolumes vf 379 return $ okResponse [] $ JSON.mapRecords (\v -> volumeJSONSimple v) p 380 -- HTML -> peeks $ blankForm . htmlVolumeSearch vf p 381 382 thumbVolume :: ActionRoute (Id Volume) 383 thumbVolume = action GET (pathId </< "thumb") $ \vi -> withAuth $ do 384 v <- getVolume PermissionPUBLIC vi 385 e <- lookupVolumeThumb v 386 maybe 387 (peeks $ otherRouteResponse [] webFile (Just $ staticPath ["images", "draft.png"])) 388 (\as -> peeks $ otherRouteResponse [] downloadAssetSegment (slotId $ view as, view as)) 389 e