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