module Model.Volume
( module Model.Volume.Types
, coreVolume
, lookupVolume
, changeVolume
, addVolume
, auditVolumeDownload
, VolumeFilter(..)
, findVolumes
, getVolumeAlias
, volumeRowJSON
, volumeJSON
, volumeJSONSimple
, updateVolumeIndex
) where
import Control.Applicative ((<|>))
import Control.Monad (guard)
import Data.List (find)
import Data.Monoid ((<>))
import Data.Semigroup hiding ((<>))
import Database.PostgreSQL.Typed.Dynamic (pgLiteralRep)
import Database.PostgreSQL.Typed.Query (pgSQL, unsafeModifyQuery)
import qualified Data.ByteString as BS
import qualified Data.Text as T
import qualified Data.Time as TM
import qualified Data.Semigroup
import Has (peek, view)
import Model.Audit
import Model.Id
import Model.Identity.Types
import Model.Paginate (Paginate (..), def)
import Model.Paginate.SQL (paginateSQL)
import Model.Party.Types
import Model.Permission
import Model.SQL (selectQuery)
import Model.Volume.SQL
import Model.Volume.Types
import Model.VolumeAccess.Types (VolumeAccess(..))
import Service.DB
import qualified JSON
coreVolume :: Volume
coreVolume = Volume
(VolumeRow (Id 0) "Core" Nothing Nothing Nothing)
(TM.UTCTime
(TM.ModifiedJulianDay 56303)
(TM.picosecondsToDiffTime 37600000000000000)
)
[]
(RolePublicViewer PublicNoPolicy)
lookupVolume
:: (MonadDB c m, MonadHasIdentity c m) => Id Volume -> m (Maybe Volume)
lookupVolume vi = do
ident :: Identity <- peek
dbQuery1 $(selectQuery (selectVolume 'ident) "$WHERE volume.id = ${vi}")
changeVolume :: MonadAudit c m => Volume -> m ()
changeVolume v = do
ident <- getAuditIdentity
dbExecute1' $(updateVolume 'ident 'v)
addVolume :: MonadAudit c m => Volume -> m Volume
addVolume bv = do
ident <- getAuditIdentity
dbQuery1' $ fmap (\v -> v [] RoleAdmin) $(insertVolume 'ident 'bv)
getVolumeAlias :: Volume -> Maybe T.Text
getVolumeAlias v = do
guard
(extractPermissionIgnorePolicy (volumeRolePolicy v) >= PermissionREAD)
volumeAlias (volumeRow v)
auditVolumeDownload :: MonadAudit c m => Bool -> Volume -> m ()
auditVolumeDownload success vol = do
ai <- getAuditIdentity
dbExecute1'
[pgSQL|$
INSERT INTO audit.volume (audit_action, audit_user, audit_ip, id)
VALUES (
${if success then AuditActionOpen else AuditActionAttempt},
${auditWho ai},
${auditIp ai},
${volumeId $ volumeRow vol})
|]
volumeRowJSON :: JSON.ToObject o => VolumeRow -> JSON.Record (Id Volume) o
volumeRowJSON VolumeRow {..} =
JSON.Record volumeId
$ "name"
JSON..= volumeName
<> "body"
JSON..= volumeBody
volumeJSON
:: JSON.ToObject o
=> Volume
-> Maybe [VolumeAccess]
-> JSON.Record (Id Volume) o
volumeJSON v@Volume{..} mAccesses =
JSON.foldObjectIntoRec
(volumeRowJSON volumeRow)
("doi" `JSON.kvObjectOrEmpty` volumeDOI volumeRow
<> "alias" `JSON.kvObjectOrEmpty` getVolumeAlias v
<> "creation" JSON..= volumeCreation
<> "owners" JSON..=
map (\(i, n) -> JSON.Object ("id" JSON..= i <> "name" JSON..= n))
volumeOwners
<> "permission" JSON..= extractPermissionIgnorePolicy volumeRolePolicy
<> "publicsharefull" JSON..= volumeAccessPolicyJSON v
<> "publicaccess" `JSON.kvObjectOrEmpty`
fmap (show . volumePublicAccessSummary) mAccesses)
volumeJSONSimple :: JSON.ToObject o => Volume -> JSON.Record (Id Volume) o
volumeJSONSimple v = volumeJSON v Nothing
volumeAccessPolicyJSON :: Volume -> Maybe Bool
volumeAccessPolicyJSON v = case volumeRolePolicy v of
RolePublicViewer PublicRestrictedPolicy -> Just False
RoleSharedViewer SharedRestrictedPolicy -> Just False
RolePublicViewer PublicNoPolicy -> Just True
_ -> Nothing
data VolumeFilter = VolumeFilter
{ volumeFilterQuery :: Maybe String
, volumeFilterParty :: Maybe (Id Party)
, volumeFilterPaginate :: Paginate
}
instance Semigroup VolumeFilter where
(<>) (VolumeFilter q1 p1 p) (VolumeFilter q2 p2 _) =
VolumeFilter (q1 <> q2) (p1 <|> p2) p
instance Monoid VolumeFilter where
mempty = VolumeFilter Nothing Nothing def
mappend = (<>)
volumeFilter :: VolumeFilter -> BS.ByteString
volumeFilter VolumeFilter {..} = BS.concat
[ withq
volumeFilterParty
(const " JOIN volume_access ON volume.id = volume_access.volume")
, withq
volumeFilterQuery
(\n ->
" JOIN volume_text_idx ON volume.id = volume_text_idx.volume, plainto_tsquery('english', "
<> pgLiteralRep n
<> ") query"
)
, " WHERE volume.id > 0 "
, withq
volumeFilterParty
(\p ->
" AND volume_access.party = "
<> pgLiteralRep p
<> " AND volume_access.individual >= 'EDIT'"
)
, withq volumeFilterQuery (const " AND ts @@ query")
, " ORDER BY "
, withq volumeFilterQuery (const "ts_rank(ts, query) DESC,")
, withq volumeFilterParty (const "volume_access.individual DESC,")
, "volume.id DESC "
, paginateSQL volumeFilterPaginate
]
where withq v f = maybe BS.empty f v
findVolumes :: (MonadHasIdentity c m, MonadDB c m) => VolumeFilter -> m [Volume]
findVolumes pf = do
ident <- peek
dbQuery $ unsafeModifyQuery
$(selectQuery (selectVolume 'ident) "")
(<> volumeFilter pf)
updateVolumeIndex :: MonadDB c m => m ()
updateVolumeIndex = dbExecute_ "SELECT volume_text_refresh()"
data VolumePublicAccessLevel
= PublicAccessFull
| PublicAccessRestricted
| PublicAccessNone
deriving (Eq)
instance Show VolumePublicAccessLevel where
show PublicAccessFull = "full"
show PublicAccessRestricted = "restricted"
show PublicAccessNone = "none"
volumePublicAccessSummary :: [VolumeAccess] -> VolumePublicAccessLevel
volumePublicAccessSummary vas = maybe
PublicAccessNone
(\va -> case volumeAccessChildren va of
PermissionNONE -> PublicAccessNone
PermissionPUBLIC ->
case
toPolicyDefaulting
(volumeAccessShareFull va)
PublicNoPolicy
PublicRestrictedPolicy
of
PublicRestrictedPolicy -> PublicAccessRestricted
PublicNoPolicy -> PublicAccessFull
_ -> PublicAccessFull
)
mPublicAccess
where
mPublicAccess =
find (\va -> (getPartyId . volumeAccessParty) va == nobodyId) vas
nobodyId = getPartyId nobodyParty