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