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