1 {-# LANGUAGE OverloadedStrings #-} 2 module Databrary.Controller.Funding 3 ( queryFunderHandler 4 , postVolumeFunding 5 , deleteVolumeFunder 6 ) where 7 8 import Control.Monad (liftM2) 9 import qualified Data.Text as T 10 11 import Databrary.Has (focusIO) 12 import qualified Databrary.JSON as JSON 13 import Databrary.Model.Id 14 import Databrary.Model.Permission 15 import Databrary.Model.Volume 16 import Databrary.Model.Funding 17 import Databrary.Model.Funding.FundRef 18 import Databrary.HTTP.Form.Deform 19 import Databrary.HTTP.Path.Parser 20 import Databrary.Action 21 import Databrary.Controller.Paths 22 import Databrary.Controller.Form 23 import Databrary.Controller.Permission 24 import Databrary.Controller.Volume 25 26 queryFunderHandler :: Action -- TODO: GET only 27 queryFunderHandler = withAuth $ do 28 _ <- authAccount 29 (q, a) <- runForm Nothing $ liftM2 (,) 30 ("query" .:> (deformRequired =<< deform)) 31 ("all" .:> deform) 32 r <- if a 33 then focusIO $ searchFundRef q 34 else findFunders q 35 return $ okResponse [] $ JSON.mapObjects funderJSON r 36 37 postVolumeFunding :: ActionRoute (Id Volume, Id Funder) 38 postVolumeFunding = action POST (pathJSON >/> pathId </> pathId) $ \(vi, fi) -> withAuth $ do 39 v <- getVolume PermissionEDIT vi 40 f <- maybeAction =<< lookupFunderRef fi 41 a <- runForm Nothing $ do 42 csrfForm 43 "awards" .:> filter (not . T.null) <$> withSubDeforms (\_ -> deform) 44 let fa = Funding f a 45 _ <- changeVolumeFunding v fa 46 return $ okResponse [] $ JSON.pairs $ fundingJSON fa 47 48 deleteVolumeFunder :: ActionRoute (Id Volume, Id Funder) 49 deleteVolumeFunder = action DELETE (pathJSON >/> pathId </> pathId) $ \(vi, fi) -> withAuth $ do 50 guardVerfHeader 51 v <- getVolume PermissionEDIT vi 52 _ <- removeVolumeFunder v fi 53 return $ okResponse [] $ JSON.recordEncoding $ volumeJSONSimple v