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