1 {-# LANGUAGE OverloadedStrings #-} 2 module Databrary.Controller.Party 3 ( getParty 4 , viewParty 5 , viewPartyEdit 6 -- , viewPartyCreate 7 , viewPartyCreateHandler 8 , viewPartyDelete 9 , postParty 10 , createParty 11 , deleteParty 12 , viewAvatar 13 , queryParties 14 , adminParties 15 , adminPartiesHandler 16 , csvPartiesHandler 17 , csvDuplicatePartiesHandler 18 ) where 19 20 import Control.Applicative (optional) 21 import Control.Monad (unless, when, forM) 22 import qualified Data.ByteString as BS 23 import qualified Data.ByteString.Char8 as BSC 24 import Data.Maybe (fromMaybe) 25 import Data.Monoid ((<>)) 26 import qualified Data.Text.Encoding as TE 27 import Network.HTTP.Types (badRequest400) 28 import qualified Network.Wai as Wai 29 import Network.Wai.Parse (FileInfo(..)) 30 31 import Databrary.Ops 32 import Databrary.Has 33 import qualified Databrary.JSON as JSON 34 import Databrary.Model.Enum 35 import Databrary.Model.Id 36 import Databrary.Model.Permission 37 import Databrary.Model.Release 38 import Databrary.Model.Party 39 import Databrary.Model.ORCID 40 import Databrary.Model.Authorize 41 import Databrary.Model.Volume 42 import Databrary.Model.VolumeAccess 43 import Databrary.Model.Asset 44 import Databrary.Model.AssetSlot 45 import Databrary.Model.AssetSegment 46 import Databrary.Model.Format 47 import Databrary.Model.Notification (Notice(NoticeNewsletter), lookupNoticePartyAuthorization) 48 import Databrary.Store.Temp 49 import Databrary.HTTP.Path.Parser 50 import Databrary.HTTP.Form.Deform 51 import Databrary.Action.Route 52 import Databrary.Action.Types 53 import Databrary.Action.Run 54 import Databrary.Action 55 import Databrary.Controller.Paths 56 import Databrary.Controller.Permission 57 import Databrary.Controller.Form 58 import Databrary.Controller.Angular 59 import Databrary.Controller.AssetSegment 60 import Databrary.Controller.Web 61 import Databrary.Controller.CSV 62 import Databrary.View.Party 63 64 -- | Ensure the current user has the requested permission for the given party. 65 getParty 66 :: Maybe Permission 67 -> PartyTarget 68 -> Handler Party 69 getParty (Just p) (TargetParty i) = 70 (\party -> checkPermission2 partyPermission p party) =<< maybeAction =<< lookupAuthParty i 71 getParty _ mi = do 72 u <- accountParty <$> authAccount 73 let isme TargetProfile = True 74 isme (TargetParty i) = partyId (partyRow u) == i 75 unless (isme mi) $ result =<< peeks forbiddenResponse 76 return u 77 78 partyJSONField :: Party -> BS.ByteString -> Maybe BS.ByteString -> Handler (Maybe JSON.Encoding) 79 partyJSONField p "parents" o = do 80 now <- peek 81 fmap (Just . JSON.mapObjects id) . mapM (\a -> do 82 let ap = authorizeParent (authorization a) 83 acc <- if auth && authorizeActive a now then Just . accessSite <$> lookupAuthorization ap rootParty else return Nothing 84 return $ (if admin then authorizeJSON a else mempty) 85 <> "party" JSON..=: (partyJSON ap `JSON.foldObjectIntoRec` ("authorization" `JSON.kvObjectOrEmpty` acc)) 86 <> "expired" `JSON.kvObjectOrEmpty` (True `useWhen` (admin && authorizeExpired a now))) 87 -- if the current user doesn't have admin over the party in question, then filter out 88 -- inactive authorizations 89 =<< lookupAuthorizedParents p (admin `unlessUse` PermissionNONE) 90 where 91 admin = partyPermission p >= PermissionADMIN 92 auth = admin && o == Just "authorization" 93 partyJSONField p "children" _ = 94 Just . JSON.mapObjects (\a -> 95 let ap = authorizeChild (authorization a) in 96 (if admin then authorizeJSON a else mempty) <> "party" JSON..=: partyJSON ap) 97 -- if the current user doesn't have admin over the party in question, then filter out 98 -- inactive authorizations 99 <$> lookupAuthorizedChildren p (admin `unlessUse` PermissionNONE) 100 where admin = partyPermission p >= PermissionADMIN 101 partyJSONField p "volumes" o = thenReturn (partyPermission p >= PermissionADMIN) $ do 102 vols <- lookupPartyVolumes p PermissionREAD 103 (fmap (JSON.mapRecords id) . mapM vf) vols 104 where 105 vf v 106 | o == Just "access" = do 107 a <- lookupVolumeAccess v (succ PermissionNONE) 108 accesses <- lookupVolumeAccess v PermissionNONE -- TODO: why different perm level 109 return $ 110 volumeJSON v (Just accesses) `JSON.foldObjectIntoRec` 111 (JSON.nestObject "access" (\u -> map (u . volumeAccessPartyJSON) a)) 112 | otherwise = return $ volumeJSONSimple v 113 partyJSONField p "access" ma = do 114 Just . JSON.mapObjects volumeAccessVolumeJSON 115 <$> lookupPartyVolumeAccess p (fromMaybe PermissionEDIT $ readDBEnum . BSC.unpack =<< ma) 116 partyJSONField p "authorization" _ = do 117 Just . JSON.toEncoding . accessSite <$> lookupAuthorization p rootParty 118 partyJSONField _ _ _ = return Nothing 119 120 partyJSONQuery :: Party -> JSON.Query -> Handler (JSON.Record (Id Party) JSON.Series) 121 partyJSONQuery p q = (partyJSON p `JSON.foldObjectIntoRec`) <$> JSON.jsonQuery (partyJSONField p) q 122 123 viewParty :: ActionRoute (API, PartyTarget) 124 viewParty = action GET (pathAPI </> pathPartyTarget) $ \(api, i) -> withAuth $ do 125 when (api == HTML) angular 126 p <- getParty (Just PermissionNONE) i 127 case api of 128 JSON -> okResponse [] <$> (partyJSONQuery p =<< peeks Wai.queryString) 129 HTML -> peeks $ okResponse [] . htmlPartyView p 130 131 -- | Extract values to build up the fields of a Party from an incoming form/json request. 132 -- One part of the extraction is reading and saving any avater image provided. 133 -- If an image is provided, also generate an asset, that is attached to the core volume. 134 -- Primarily extracting values that correspond to a PartyRow, all other values (account, permissions) are 135 -- taken from blankParty or the existing party. 136 -- This is used by createParty with no party provided, and postParty with existing party provided. 137 processParty 138 :: API -- ^ Whether this request is being handled as part of a server side form handler, or a client side API request 139 -> Maybe Party -- ^ The existing version of the party, before any updates 140 -> Handler (Party, Maybe (Maybe Asset)) -- ^ A party object populated with the request input and a possible avatar asset. 141 processParty api p = do 142 (p', a) <- runFormFiles [("avatar", maxAvatarSize)] ((api == HTML) `thenUse` (htmlPartyEdit p)) $ do 143 csrfForm 144 name <- "sortname" .:> (deformRequired =<< deform) 145 prename <- "prename" .:> deformNonEmpty deform 146 mOrcid <- "orcid" .:> deformNonEmpty (deformRead blankORCID) 147 affiliation <- "affiliation" .:> deformNonEmpty deform 148 url <- "url" .:> deformNonEmpty deform 149 (avatar :: (Maybe (Maybe (FileInfo TempFile, Format)))) <- "avatar" .:> do 150 mFileInfo <- deform 151 (maybe 152 (deformOptional $ return Nothing) 153 (\avatarFileInfo -> do 154 format <- do 155 fmt <- 156 deformMaybe' "Unknown or unsupported file format." (getFormatByFilename (fileName avatarFileInfo)) 157 deformCheck "Must be an image." formatIsImage fmt 158 return $ Just $ Just (avatarFileInfo, format)) 159 mFileInfo) 160 return (bp 161 { partyRow = (partyRow bp) 162 { partySortName = name 163 , partyPreName = prename 164 , partyORCID = mOrcid 165 , partyAffiliation = affiliation 166 , partyURL = url 167 } 168 }, avatar) 169 a' <- forM a $ mapM $ \(af, fmt) -> do 170 let ba = blankAsset coreVolume 171 a' <- addAsset ba 172 { assetRow = (assetRow ba) 173 { assetFormat = fmt 174 , assetRelease = Just ReleasePUBLIC 175 , assetName = Just $ TE.decodeUtf8 $ fileName af 176 } 177 } $ Just $ tempFilePath (fileContent af) 178 focusIO $ releaseTempFile $ fileContent af 179 return a' 180 return (p', a') 181 where 182 maxAvatarSize = 10*1024*1024 183 bp = fromMaybe blankParty p 184 185 viewPartyEdit :: ActionRoute PartyTarget 186 viewPartyEdit = action GET (pathHTML >/> pathPartyTarget </< "edit") $ \i -> withAuth $ do 187 angular 188 p <- getParty (Just PermissionEDIT) i 189 peeks $ blankForm . htmlPartyEdit (Just p) 190 191 viewPartyCreateHandler :: Action 192 viewPartyCreateHandler = withAuth $ do 193 checkMemberADMIN 194 peeks $ blankForm . htmlPartyEdit Nothing 195 196 postParty :: ActionRoute (API, PartyTarget) 197 postParty = multipartAction $ action POST (pathAPI </> pathPartyTarget) $ \(api, i) -> withAuth $ do 198 p <- getParty (Just PermissionEDIT) i 199 (p', a) <- processParty api (Just p) 200 changeParty p' 201 mapM_ (changeAvatar p') a 202 case api of 203 JSON -> return $ okResponse [] $ JSON.recordEncoding $ partyJSON p' 204 HTML -> peeks $ otherRouteResponse [] viewParty (api, i) 205 206 -- | Create a new party, starting from blankParty, then overlaying data extracted from request. 207 -- Since this overlaps with how registration creates an account/party combo, this is only used when creating 208 -- parties manually by a superadmin, such as creating institution parties which don't have an account. 209 createParty :: ActionRoute API 210 createParty = multipartAction $ action POST (pathAPI </< "party") $ \api -> withAuth $ do 211 checkMemberADMIN 212 (bp, a) <- processParty api Nothing 213 p <- addParty bp 214 mapM_ (changeAvatar p) a 215 case api of 216 JSON -> return $ okResponse [] $ JSON.recordEncoding $ partyJSON p 217 HTML -> peeks $ otherRouteResponse [] viewParty (api, TargetParty $ partyId $ partyRow p) 218 219 deleteParty :: ActionRoute (Id Party) 220 deleteParty = action POST (pathHTML >/> pathId </< "delete") $ \i -> withAuth $ do 221 checkMemberADMIN 222 p <- getParty (Just PermissionADMIN) (TargetParty i) 223 r <- removeParty p 224 return $ if r 225 then okResponse [] $ partyName (partyRow p) <> " deleted" 226 else response badRequest400 [] $ partyName (partyRow p) <> " not deleted" 227 228 viewPartyDelete :: ActionRoute (Id Party) 229 viewPartyDelete = action GET (pathHTML >/> pathId </< "delete") $ \i -> withAuth $ do 230 checkMemberADMIN 231 p <- getParty (Just PermissionADMIN) (TargetParty i) 232 peeks $ blankForm . htmlPartyDelete p 233 234 viewAvatar :: ActionRoute (Id Party) 235 viewAvatar = action GET (pathId </< "avatar") $ \i -> withoutAuth $ 236 maybe 237 (peeks $ otherRouteResponse [] webFile (Just $ staticPath ["images", "avatar.png"])) 238 (serveAssetSegment False . assetSlotSegment . assetNoSlot) 239 =<< lookupAvatar i 240 241 partySearchForm :: DeformHandler f PartyFilter 242 partySearchForm = PartyFilter 243 <$> ("query" .:> deformNonEmpty deform) 244 <*> ("authorization" .:> optional deform) 245 <*> ("institution" .:> deformNonEmpty deform) 246 <*> paginateForm 247 248 queryParties :: ActionRoute API 249 queryParties = action GET (pathAPI </< "party") $ \api -> withAuth $ do 250 when (api == HTML) angular 251 pf <- runForm ((api == HTML) `thenUse` (htmlPartySearch mempty [])) partySearchForm 252 p <- findParties pf 253 case api of 254 JSON -> return $ okResponse [] $ JSON.mapRecords partyJSON p 255 HTML -> peeks $ blankForm . htmlPartySearch pf p 256 257 adminParties :: ActionRoute () 258 adminParties = action GET ("party" </< "admin") $ \() -> adminPartiesHandler 259 260 adminPartiesHandler :: Action --TODO: GET only 261 adminPartiesHandler = withAuth $ do 262 checkMemberADMIN 263 pf <- runForm (Just $ htmlPartyAdmin mempty []) partySearchForm 264 p <- findParties pf 265 peeks $ blankForm . htmlPartyAdmin pf p 266 267 csvPartiesHandler :: Action -- TODO: GET only 268 csvPartiesHandler = withAuth $ do 269 checkMemberADMIN 270 pl <- lookupNoticePartyAuthorization NoticeNewsletter 271 return $ csvResponse 272 [ [ BSC.pack $ show $ partyId $ partyRow p 273 , TE.encodeUtf8 $ partySortName $ partyRow p 274 , c TE.encodeUtf8 $ partyPreName $ partyRow p 275 , c accountEmail $ partyAccount p 276 , c (BSC.pack . show) a 277 , BSC.pack $ show $ fromEnum d 278 ] 279 | (p, a, d) <- pl ] "party" 280 where c = maybe BS.empty 281 282 csvDuplicatePartiesHandler :: Action -- TODO: GET only 283 csvDuplicatePartiesHandler = withAuth $ do 284 checkMemberADMIN 285 ps <- getDuplicateParties 286 return $ csvResponse 287 [ [ BSC.pack $ show $ partyId $ partyRow1 288 , TE.encodeUtf8 $ partySortName $ partyRow1 289 , maybeEmpty TE.encodeUtf8 (partyPreName $ partyRow1) 290 ] 291 | partyRow1 <- ps ] "party" 292 where 293 maybeEmpty :: (a -> BS.ByteString) -> Maybe a -> BS.ByteString 294 maybeEmpty = maybe BS.empty