module Controller.Volume
( getVolume
, viewVolume
, viewVolumeEdit
, viewVolumeCreateHandler
, postVolume
, createVolume
, postVolumeLinks
, postVolumeAssist
, queryVolumes
, thumbVolume
, volumeDownloadName
, volumeIsPublicRestricted
) where
import Control.Applicative ((<|>), optional)
import Control.Arrow ((&&&), (***))
import Control.Monad (mfilter, guard, void, when, forM_)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Lazy (StateT(..), evalStateT, get, put)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.HashMap.Lazy as HML
import qualified Data.HashMap.Strict as HM
import Data.Function (on)
import Data.Int (Int16)
import Data.Maybe (fromMaybe, isNothing)
import Data.Monoid ((<>))
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Network.HTTP.Types (noContent204, unsupportedMediaType415)
import Network.URI (URI)
import qualified Network.Wai as Wai
import Ops
import Has
import qualified JSON
import Model.Access
import Model.Asset (Asset)
import Model.Enum
import Model.Id
import Model.Permission hiding (checkPermission)
import Model.Authorize
import Model.Volume
import Model.VolumeAccess
import Model.Party
import Model.Citation
import Model.Citation.CrossRef
import Model.Funding
import Model.Container
import Model.Record
import Model.VolumeMetric
import Model.RecordSlot
import Model.Segment (Segment)
import Model.Slot
import Model.AssetSlot
import Model.Excerpt
import Model.Tag
import Model.Comment
import Model.VolumeState
import Model.Notification.Types
import Store.Filename
import Static.Service
import Service.Mail
import HTTP.Parse
import HTTP.Form.Deform
import HTTP.Path.Parser
import Action.Route
import Action
import Controller.Paths
import Controller.Permission
import Controller.Form
import Controller.Angular
import Controller.Web
import Controller.AssetSegment
import Controller.Notification
import View.Form (FormHtml)
getVolume
:: Permission
-> Id Volume
-> Handler Volume
getVolume requestedPerm volId = do
res <- accessVolume requestedPerm volId
case res of
LookupFailed -> result =<< peeks notFoundResponse
AccessDenied -> result =<< peeks forbiddenResponse
AccessResult v -> pure v
data VolumeCache = VolumeCache
{ volumeCacheAccess :: Maybe [VolumeAccess]
, volumeCacheTopContainer :: Maybe Container
, volumeCacheRecords :: Maybe (HML.HashMap (Id Record) Record)
}
instance Monoid VolumeCache where
mempty = VolumeCache Nothing Nothing Nothing
mappend (VolumeCache a1 t1 r1) (VolumeCache a2 t2 r2) = VolumeCache (a1 <|> a2) (t1 <|> t2) (r1 <> r2)
runVolumeCache :: StateT VolumeCache Handler a -> Handler a
runVolumeCache f = evalStateT f mempty
cacheVolumeAccess :: Volume -> Permission -> StateT VolumeCache Handler [VolumeAccess]
cacheVolumeAccess vol perm = do
vc <- get
takeWhile ((perm <=) . volumeAccessIndividual) <$>
fromMaybeM (do
a <- lookupVolumeAccess vol PermissionNONE
put vc{ volumeCacheAccess = Just a }
return a)
(volumeCacheAccess vc)
cacheVolumeRecords :: Volume -> StateT VolumeCache Handler ([Record], HML.HashMap (Id Record) Record)
cacheVolumeRecords vol = do
vc <- get
maybe (do
l <- lookupVolumeRecords vol
let m = HML.fromList [ (recordId $ recordRow r, r) | r <- l ]
put vc{ volumeCacheRecords = Just m }
return (l, m))
(return . (HML.elems &&& id))
(volumeCacheRecords vc)
cacheVolumeTopContainer :: Volume -> StateT VolumeCache Handler Container
cacheVolumeTopContainer vol = do
vc <- get
fromMaybeM (do
t <- lookupVolumeTopContainer vol
put vc{ volumeCacheTopContainer = Just t }
return t)
(volumeCacheTopContainer vc)
leftJoin :: (a -> b -> Bool) -> [a] -> [b] -> [(a, [b])]
leftJoin _ [] [] = []
leftJoin _ [] _ = error "leftJoin: leftovers"
leftJoin p (a:al) b = uncurry (:) $ (,) a *** leftJoin p al $ span (p a) b
volumeIsPublicRestricted :: Volume -> Bool
volumeIsPublicRestricted v =
case volumeRolePolicy v of
RolePublicViewer PublicRestrictedPolicy -> True
RoleSharedViewer SharedRestrictedPolicy -> True
_ -> False
volumeJSONField :: Volume -> BS.ByteString -> Maybe BS.ByteString -> StateT VolumeCache Handler (Maybe JSON.Encoding)
volumeJSONField vol "access" ma =
Just . JSON.mapObjects volumeAccessPartyJSON
<$> cacheVolumeAccess vol (fromMaybe PermissionNONE $ readDBEnum . BSC.unpack =<< ma)
volumeJSONField vol "citation" _ =
Just . JSON.toEncoding <$> lookupVolumeCitation vol
volumeJSONField vol "links" _ =
Just . JSON.toEncoding <$> lookupVolumeLinks vol
volumeJSONField vol "funding" _ =
Just . JSON.mapObjects fundingJSON <$> lookupVolumeFunding vol
volumeJSONField vol "containers" mContainersVal = do
(cl :: [(Container, [(Segment, Id Record)])]) <- if records
then lookupVolumeContainersRecordIds vol
else nope <$> lookupVolumeContainers vol
(cl' :: [((Container, [(Segment, Id Record)]), [(Asset, SlotId)])]) <- if assets
then leftJoin (\(c, _) (_, SlotId a _) -> containerId (containerRow c) == a) cl <$> lookupVolumeAssetSlotIds vol
else return $ nope cl
rm <- if records then snd <$> cacheVolumeRecords vol else return HM.empty
let publicRestricted = volumeIsPublicRestricted vol
br = blankRecord undefined vol
rjs c (s, r) = JSON.recordObject $ recordSlotJSON publicRestricted $ RecordSlot (HML.lookupDefault br{ recordRow = (recordRow br){ recordId = r } } r rm) (Slot c s)
ajs c (a, SlotId _ s) = JSON.recordObject $ assetSlotJSON publicRestricted $ AssetSlot a (Just (Slot c s))
return $ Just $ JSON.mapRecords (\((c, rl), al) ->
containerJSON publicRestricted c
`JSON.foldObjectIntoRec`
( (if records then JSON.nestObject "records" (\u -> map (u . rjs c) rl) else mempty)
<> (if assets then JSON.nestObject "assets" (\u -> map (u . ajs c) al) else mempty)))
cl'
where
full = mContainersVal == Just "all"
assets = full || mContainersVal == Just "assets"
records = full || mContainersVal == Just "records"
nope = map (, [])
volumeJSONField vol "top" _ = do
topCntr <- cacheVolumeTopContainer vol
let publicRestricted = volumeIsPublicRestricted vol
(return . Just . JSON.recordEncoding . containerJSON publicRestricted) topCntr
volumeJSONField vol "records" _ = do
(l, _) <- cacheVolumeRecords vol
let publicRestricted = volumeIsPublicRestricted vol
return $ Just $ JSON.mapRecords (recordJSON publicRestricted) l
volumeJSONField vol "metrics" _ =
let metricsCaching = lookupVolumeMetrics vol
in (Just . JSON.toEncoding) <$> metricsCaching
volumeJSONField vol "excerpts" _ =
Just . JSON.mapObjects (\e -> excerptJSON e
<> "asset" JSON..=: (assetSlotJSON False (view e)
`JSON.foldObjectIntoRec` ("container" JSON..= (view e :: Id Container))))
<$> lookupVolumeExcerpts vol
volumeJSONField vol "tags" n = do
t <- cacheVolumeTopContainer vol
tc <- lookupSlotTagCoverage (containerSlot t) (maybe 64 fst $ BSC.readInt =<< n)
return $ Just $ JSON.mapRecords tagCoverageJSON tc
volumeJSONField vol "comments" n = do
t <- cacheVolumeTopContainer vol
tc <- lookupSlotComments (containerSlot t) (maybe 64 fst $ BSC.readInt =<< n)
return $ Just $ JSON.mapRecords commentJSON tc
volumeJSONField vol "state" _ =
Just . JSON.toEncoding . JSON.object . map (volumeStateKey &&& volumeStateValue) <$> lookupVolumeState ((volumeId . volumeRow) vol) (volumeRolePolicy vol)
volumeJSONField o "filename" _ =
return $ Just $ JSON.toEncoding $ makeFilename $ volumeDownloadName o
volumeJSONField _ _ _ = return Nothing
volumeJSONQuery :: Volume -> Maybe [VolumeAccess] -> JSON.Query -> Handler (JSON.Record (Id Volume) JSON.Series)
volumeJSONQuery vol mAccesses q =
let seriesCaching :: StateT VolumeCache Handler JSON.Series
seriesCaching = JSON.jsonQuery (volumeJSONField vol) q
expandedVolJSONcaching :: StateT VolumeCache Handler (JSON.Record (Id Volume) JSON.Series)
expandedVolJSONcaching = (\series -> volumeJSON vol mAccesses `JSON.foldObjectIntoRec` series) <$> seriesCaching
in
runVolumeCache expandedVolJSONcaching
volumeDownloadName :: Volume -> [T.Text]
volumeDownloadName v =
T.pack ("databrary" ++ show (volumeId $ volumeRow v))
: map (T.takeWhile (',' /=) . snd) (volumeOwners v)
++ [fromMaybe (volumeName $ volumeRow v) (getVolumeAlias v)]
viewVolume :: ActionRoute (API, Id Volume)
viewVolume = action GET (pathAPI </> pathId) $ \(api, vi) -> withAuth $ do
when (api == HTML) angular
v <- getVolume PermissionPUBLIC vi
accesses <- lookupVolumeAccess v PermissionNONE
let idSeriesRecAct :: Handler (JSON.Record (Id Volume) JSON.Series)
idSeriesRecAct = volumeJSONQuery v (Just accesses) =<< peeks Wai.queryString
okResponse [] . JSON.recordEncoding <$> idSeriesRecAct
data CreateOrUpdateVolumeCitationRequest =
CreateOrUpdateVolumeCitationRequest
T.Text
(Maybe T.Text)
(Maybe T.Text)
T.Text
(Maybe URI)
(Maybe Int16)
volumeForm :: Volume -> DeformHandler f Volume
volumeForm v = do
name <- "name" .:> deform
alias <- "alias" .:> deformNonEmpty deform
body <- "body" .:> deformNonEmpty deform
return v
{ volumeRow = (volumeRow v)
{ volumeName = name
, volumeAlias = alias
, volumeBody = body
}
}
volumeCitationForm :: Volume -> DeformHandler f (Volume, Maybe Citation, CreateOrUpdateVolumeCitationRequest)
volumeCitationForm v = do
csrfForm
vol <- volumeForm v
cite <- "citation" .:> Citation
<$> ("head" .:> deform)
<*> ("url" .:> deformNonEmpty deform)
<*> ("year" .:> deformNonEmpty deform)
<*> pure Nothing
let createOrUpdateVolumeCitationRequest =
CreateOrUpdateVolumeCitationRequest
((volumeName . volumeRow) vol)
((volumeAlias . volumeRow) vol)
((volumeBody . volumeRow) vol)
(citationHead cite)
(citationURL cite)
(citationYear cite)
look <- flatMapM (lift . focusIO . lookupCitation) $
guard (T.null (volumeName $ volumeRow vol) || T.null (citationHead cite) || isNothing (citationYear cite)) >> citationURL cite
let fill = maybe cite (cite <>) look
empty = T.null (citationHead fill) && isNothing (citationURL fill) && isNothing (citationYear fill)
name
| Just title <- citationTitle fill
, T.null (volumeName $ volumeRow vol) = title
| otherwise = volumeName $ volumeRow vol
_ <- "name" .:> deformRequired name
when (not empty) $ void $
"citation" .:> "head" .:> deformRequired (citationHead fill)
return (vol{ volumeRow = (volumeRow vol){ volumeName = name } }, empty `unlessUse` fill, createOrUpdateVolumeCitationRequest)
viewVolumeEdit :: ActionRoute (Id Volume)
viewVolumeEdit = action GET (pathHTML >/> pathId </< "edit") $ \_ -> withAuth $ do
angular
return (okResponse [] ("" :: String))
viewVolumeCreateHandler :: Action
viewVolumeCreateHandler = withAuth $ do
angular
return (okResponse [] ("" :: String))
postVolume :: ActionRoute (Id Volume)
postVolume = action POST (pathJSON >/> pathId) $ \vi -> withAuth $ do
v <- getVolume PermissionEDIT vi
cite <- lookupVolumeCitation v
(v', cite', _) <- runForm (Nothing :: Maybe (RequestContext -> FormHtml a)) $ volumeCitationForm v
changeVolume v'
r <- changeVolumeCitation v' cite'
return $ okResponse [] $
JSON.recordEncoding $ volumeJSONSimple v' `JSON.foldObjectIntoRec` ("citation" JSON..= if r then cite' else cite)
data CreateVolumeRequest =
CreateVolumeRequest (Maybe (Id Party)) CreateOrUpdateVolumeCitationRequest
createVolume :: ActionRoute ()
createVolume = action POST (pathJSON >/> "volume") $ \() -> withAuth $ do
u <- peek
(bv, cite, owner) <- runForm (Nothing :: Maybe (RequestContext -> FormHtml a)) $ do
csrfForm
(bv, cite, req) <- volumeCitationForm blankVolume
own <- "owner" .:> do
oi <- deformOptional deform
let _ = CreateVolumeRequest oi req
own <- maybe (return $ Just $ selfAuthorize u) (lift . lookupAuthorizeParent u) $ mfilter (partyId (partyRow u) /=) oi
deformMaybe' "You are not authorized to create volumes for that owner." $
authorizeParent . authorization <$> mfilter ((PermissionADMIN <=) . accessMember) own
auth <- lift $ lookupAuthorization own rootParty
deformGuard "Insufficient site authorization to create volume." $
PermissionEDIT <= accessSite auth
return (bv, cite, own)
v <- addVolume bv
_ <- changeVolumeCitation v cite
setDefaultVolumeAccessesForCreated owner v
when (on (/=) (partyId . partyRow) owner u) $ forM_ (partyAccount owner) $ \t ->
createNotification (blankNotification t NoticeVolumeCreated)
{ notificationVolume = Just $ volumeRow v
, notificationParty = Just $ partyRow owner
}
return $ okResponse [] $ JSON.recordEncoding $ volumeJSONSimple v
newtype UpdateVolumeLinksRequest =
UpdateVolumeLinksRequest [(T.Text, Maybe URI)]
postVolumeLinks :: ActionRoute (Id Volume)
postVolumeLinks = action POST (pathJSON >/> pathId </< "link") $ \vi -> withAuth $ do
v <- getVolume PermissionEDIT vi
links' <- runForm (Nothing :: Maybe (RequestContext -> FormHtml a)) $ do
csrfForm
res <- withSubDeforms $ \_ -> Citation
<$> ("head" .:> deform)
<*> ("url" .:> (Just <$> deform))
<*> pure Nothing
<*> pure Nothing
let _ = UpdateVolumeLinksRequest (fmap (\c -> (citationHead c, citationURL c)) res)
pure res
changeVolumeLinks v links'
return $ okResponse [] $ JSON.recordEncoding $ volumeJSONSimple v `JSON.foldObjectIntoRec` ("links" JSON..= links')
postVolumeAssist :: ActionRoute (Id Volume)
postVolumeAssist = action POST (pathJSON >/> pathId </< "assist") $ \vi -> withAuth $ do
user <- authAccount
v <- getVolume PermissionEDIT vi
addr <- peeks staticAssistAddr
cont <- parseRequestContent (const 0)
body <- case cont :: Content () of
ContentText body -> return body
_ -> result $ emptyResponse unsupportedMediaType415 []
sendMail [Left addr] [Right user] ("Databrary upload assistance request for volume " <> T.pack (show vi)) $ TL.fromChunks
[ partyName $ partyRow $ accountParty user, " has requested curation assistance for ", volumeName $ volumeRow v, "\n\n" ] <> body `TL.snoc` '\n'
createVolumeNotification v ($ NoticeVolumeAssist)
return $ emptyResponse noContent204 []
volumeSearchForm :: DeformHandler f VolumeFilter
volumeSearchForm = VolumeFilter
<$> ("query" .:> deformNonEmpty deform)
<*> ("party" .:> optional deform)
<*> paginateForm
queryVolumes :: ActionRoute API
queryVolumes = action GET (pathAPI </< "volume") $ \api -> withAuth $ do
when (api == HTML) angular
vf <- runForm (Nothing :: Maybe (RequestContext -> FormHtml a)) volumeSearchForm
p <- findVolumes vf
return $ okResponse [] $ JSON.mapRecords volumeJSONSimple p
thumbVolume :: ActionRoute (Id Volume)
thumbVolume = action GET (pathId </< "thumb") $ \vi -> withAuth $ do
v <- getVolume PermissionPUBLIC vi
e <- lookupVolumeThumb v
maybe
(peeks $ otherRouteResponse [] webFile (Just $ staticPath ["images", "draft.png"]))
(\as -> peeks $ otherRouteResponse [] downloadAssetSegment (slotId $ view as, view as))
e