module Controller.Funding
( queryFunderHandler
, postVolumeFunding
, deleteVolumeFunder
) where
import Control.Monad (liftM2)
import qualified Data.Text as T
import Has (focusIO)
import qualified JSON
import Model.Id
import Model.Permission
import Model.Volume
import Model.Funding
import Model.Funding.FundRef
import HTTP.Form.Deform
import HTTP.Path.Parser
import Action
import Controller.Paths
import Controller.Form
import Controller.Permission
import Controller.Volume
data QueryFundersRequest = QueryFundersRequest T.Text Bool
queryFunderHandler :: Action
queryFunderHandler = withAuth $ do
_ <- authAccount
QueryFundersRequest q a <- runForm Nothing $ liftM2 QueryFundersRequest
("query" .:> (deformRequired =<< deform))
("all" .:> deform)
r <- QueryFunderResponse <$> if a
then focusIO $ searchFundRef q
else findFunders q
return $ okResponse [] $ (JSON.mapObjects funderJSON . unwrap) r
newtype QueryFunderResponse = QueryFunderResponse { unwrap :: [Funder] }
data CreateOrUpdateVolumeFundingRequest =
CreateOrUpdateVolumeFundingRequest [T.Text]
postVolumeFunding :: ActionRoute (Id Volume, Id Funder)
postVolumeFunding = action POST (pathJSON >/> pathId </> pathId) $ \(vi, fi) -> withAuth $ do
v <- getVolume PermissionEDIT vi
f <- maybeAction =<< lookupFunderRef fi
CreateOrUpdateVolumeFundingRequest a <- runForm Nothing $ do
csrfForm
CreateOrUpdateVolumeFundingRequest <$> ("awards" .:> filter (not . T.null) <$> withSubDeforms (\_ -> deform))
let resp@(AddVolumeFundingResponse fa) = AddVolumeFundingResponse (Funding f a)
_ <- changeVolumeFunding v fa
return $ okResponse [] $ JSON.pairs $ (fundingJSON . avfUnwrap) resp
newtype AddVolumeFundingResponse = AddVolumeFundingResponse { avfUnwrap :: Funding }
deleteVolumeFunder :: ActionRoute (Id Volume, Id Funder)
deleteVolumeFunder = action DELETE (pathJSON >/> pathId </> pathId) $ \(vi, fi) -> withAuth $ do
guardVerfHeader
v <- getVolume PermissionEDIT vi
_ <- removeVolumeFunder v fi
return $ okResponse [] $ JSON.recordEncoding $ volumeJSONSimple v