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