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