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