1 {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, RecordWildCards, ScopedTypeVariables, DataKinds #-}
    2 module Databrary.Model.Volume
    3   ( module Databrary.Model.Volume.Types
    4   , coreVolume
    5   , lookupVolume
    6   , changeVolume
    7   , addVolume
    8   , auditVolumeDownload
    9   , VolumeFilter(..)
   10   , findVolumes
   11   , getVolumeAlias
   12   , volumeRowJSON
   13   , volumeJSON
   14   , volumeJSONSimple
   15   , updateVolumeIndex
   16   ) where
   17 
   18 import Control.Applicative ((<|>))
   19 import Control.Monad (guard)
   20 import qualified Data.ByteString as BS
   21 import Data.List (find)
   22 import Data.Monoid ((<>))
   23 import qualified Data.Time as TM
   24 import qualified Data.Text as T
   25 import Database.PostgreSQL.Typed.Query (pgSQL, unsafeModifyQuery)
   26 import Database.PostgreSQL.Typed.Dynamic (pgLiteralRep)
   27 
   28 import Databrary.Has (peek, view)
   29 import Databrary.Service.DB
   30 import qualified Databrary.JSON as JSON
   31 import Databrary.Model.SQL (selectQuery)
   32 import Databrary.Model.Paginate (Paginate (..), def)
   33 import Databrary.Model.Paginate.SQL (paginateSQL)
   34 import Databrary.Model.Id
   35 import Databrary.Model.Permission
   36 import Databrary.Model.Audit
   37 import Databrary.Model.Party.Types
   38 import Databrary.Model.Identity.Types
   39 import Databrary.Model.Volume.Types
   40 import Databrary.Model.Volume.SQL
   41 import Databrary.Model.VolumeAccess.Types (VolumeAccess(..))
   42 
   43 coreVolume :: Volume
   44 coreVolume = -- TODO: load on startup in lookups service module
   45       Volume
   46             (VolumeRow (Id 0) (T.pack "Core") Nothing Nothing Nothing)
   47             (TM.UTCTime
   48                 (TM.ModifiedJulianDay 56303)
   49                 (TM.picosecondsToDiffTime 37600000000000000))
   50             []
   51             (RolePublicViewer PublicNoPolicy)
   52 
   53 lookupVolume :: (MonadDB c m, MonadHasIdentity c m) => Id Volume -> m (Maybe Volume)
   54 lookupVolume vi = do
   55   ident :: Identity <- peek
   56   dbQuery1 $(selectQuery (selectVolume 'ident) "$WHERE volume.id = ${vi}")
   57 
   58 changeVolume :: MonadAudit c m => Volume -> m ()
   59 changeVolume v = do
   60   ident <- getAuditIdentity
   61   dbExecute1' $(updateVolume 'ident 'v)
   62 
   63 addVolume :: MonadAudit c m => Volume -> m Volume
   64 addVolume bv = do
   65   ident <- getAuditIdentity
   66   dbQuery1' $ fmap (\v -> v [] RoleAdmin) $(insertVolume 'ident 'bv)
   67 
   68 getVolumeAlias :: Volume -> Maybe T.Text
   69 getVolumeAlias v = guard ((extractPermissionIgnorePolicy . volumeRolePolicy) v >= PermissionREAD) >> volumeAlias (volumeRow v)
   70 
   71 auditVolumeDownload :: MonadAudit c m => Bool -> Volume -> m ()
   72 auditVolumeDownload success vol = do
   73   ai <- getAuditIdentity
   74   dbExecute1' [pgSQL|$INSERT INTO audit.volume (audit_action, audit_user, audit_ip, id) VALUES
   75     (${if success then AuditActionOpen else AuditActionAttempt}, ${auditWho ai}, ${auditIp ai}, ${volumeId $ volumeRow vol})|]
   76 
   77 volumeRowJSON :: JSON.ToObject o => VolumeRow -> JSON.Record (Id Volume) o
   78 volumeRowJSON VolumeRow{..} = JSON.Record volumeId $
   79      "name" JSON..= volumeName
   80   <> "body" JSON..= volumeBody
   81 
   82 volumeJSON :: JSON.ToObject o => Volume -> Maybe [VolumeAccess] -> JSON.Record (Id Volume) o
   83 volumeJSON v@Volume{..} mAccesses =
   84     volumeRowJSON volumeRow `JSON.foldObjectIntoRec`
   85    (
   86        "doi" `JSON.kvObjectOrEmpty` volumeDOI volumeRow
   87     <> "alias" `JSON.kvObjectOrEmpty` getVolumeAlias v
   88     <> "creation" JSON..= volumeCreation
   89     <> "owners" JSON..= map (\(i, n) -> JSON.Object $ "id" JSON..= i <> "name" JSON..= n) volumeOwners
   90     <> "permission" JSON..= extractPermissionIgnorePolicy volumeRolePolicy
   91     <> "publicsharefull" JSON..= volumeAccessPolicyJSON v
   92     <> "publicaccess" `JSON.kvObjectOrEmpty` fmap (show . volumePublicAccessSummary) mAccesses)
   93 
   94 volumeJSONSimple :: JSON.ToObject o => Volume -> JSON.Record (Id Volume) o
   95 volumeJSONSimple v = volumeJSON v Nothing
   96 
   97 volumeAccessPolicyJSON :: Volume -> Maybe Bool
   98 volumeAccessPolicyJSON v =
   99   case volumeRolePolicy v of
  100     RolePublicViewer PublicRestrictedPolicy -> Just False
  101     RoleSharedViewer SharedRestrictedPolicy -> Just False
  102     RolePublicViewer PublicNoPolicy -> Just True
  103     _ -> Nothing
  104 
  105 data VolumeFilter = VolumeFilter
  106   { volumeFilterQuery :: Maybe String
  107   , volumeFilterParty :: Maybe (Id Party)
  108   , volumeFilterPaginate :: Paginate
  109   }
  110 
  111 instance Monoid VolumeFilter where
  112   mempty = VolumeFilter Nothing Nothing def
  113   mappend (VolumeFilter q1 p1 p) (VolumeFilter q2 p2 _) =
  114     VolumeFilter (q1 <> q2) (p1 <|> p2) p
  115 
  116 volumeFilter :: VolumeFilter -> BS.ByteString
  117 volumeFilter VolumeFilter{..} = BS.concat
  118   [ withq volumeFilterParty (const " JOIN volume_access ON volume.id = volume_access.volume")
  119   , withq volumeFilterQuery (\n -> " JOIN volume_text_idx ON volume.id = volume_text_idx.volume, plainto_tsquery('english', " <> pgLiteralRep n <> ") query")
  120   , " WHERE volume.id > 0 "
  121   , withq volumeFilterParty (\p -> " AND volume_access.party = " <> pgLiteralRep p <> " AND volume_access.individual >= 'EDIT'")
  122   , withq volumeFilterQuery (const " AND ts @@ query")
  123   , " ORDER BY "
  124   , withq volumeFilterQuery (const "ts_rank(ts, query) DESC,")
  125   , withq volumeFilterParty (const "volume_access.individual DESC,")
  126   , "volume.id DESC "
  127   , paginateSQL volumeFilterPaginate
  128   ]
  129   where
  130   withq v f = maybe BS.empty f v
  131 
  132 findVolumes :: (MonadHasIdentity c m, MonadDB c m) => VolumeFilter -> m [Volume]
  133 findVolumes pf = do
  134   ident <- peek
  135   dbQuery $ unsafeModifyQuery $(selectQuery (selectVolume 'ident) "")
  136     (<> volumeFilter pf)
  137 
  138 updateVolumeIndex :: MonadDB c m => m ()
  139 updateVolumeIndex =
  140   dbExecute_ "SELECT volume_text_refresh()"
  141 
  142 data VolumePublicAccessLevel = PublicAccessFull | PublicAccessRestricted | PublicAccessNone deriving (Eq)
  143 
  144 instance Show VolumePublicAccessLevel where
  145   show PublicAccessFull = "full"
  146   show PublicAccessRestricted = "restricted"
  147   show PublicAccessNone = "none"
  148 
  149 volumePublicAccessSummary :: [VolumeAccess] -> VolumePublicAccessLevel
  150 volumePublicAccessSummary vas =
  151   maybe
  152     PublicAccessNone
  153     (\va ->
  154        case volumeAccessChildren va of
  155          PermissionNONE -> PublicAccessNone
  156          PermissionPUBLIC ->
  157            case toPolicyDefaulting (volumeAccessShareFull va) PublicNoPolicy PublicRestrictedPolicy of
  158              PublicRestrictedPolicy -> PublicAccessRestricted
  159              PublicNoPolicy -> PublicAccessFull
  160          _ -> PublicAccessFull)
  161     mPublicAccess
  162   where
  163     -- can't use equality on parties because Party is a circular type
  164     mPublicAccess = find (\va -> (getPartyId . volumeAccessParty) va == nobodyId) vas
  165     nobodyId = getPartyId nobodyParty