1 {-# LANGUAGE OverloadedStrings #-}
    2 module 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 Has (focusIO)
   12 import qualified JSON
   13 import Model.Id
   14 import Model.Permission
   15 import Model.Volume
   16 import Model.Funding
   17 import Model.Funding.FundRef
   18 import HTTP.Form.Deform
   19 import HTTP.Path.Parser
   20 import Action
   21 import Controller.Paths
   22 import Controller.Form
   23 import Controller.Permission
   24 import Controller.Volume
   25 
   26 data QueryFundersRequest = QueryFundersRequest T.Text Bool
   27 
   28 queryFunderHandler :: Action -- TODO: GET only
   29 queryFunderHandler = withAuth $ do
   30   _ <- authAccount
   31   QueryFundersRequest q a <- runForm Nothing $ liftM2 QueryFundersRequest
   32     ("query" .:> (deformRequired =<< deform))
   33     ("all" .:> deform)
   34   r <- QueryFunderResponse <$> if a
   35     then focusIO $ searchFundRef q
   36     else findFunders q
   37   return $ okResponse [] $ (JSON.mapObjects funderJSON . unwrap) r
   38 
   39 -- | Body of funder query response
   40 newtype QueryFunderResponse = QueryFunderResponse { unwrap :: [Funder] }
   41 
   42 data CreateOrUpdateVolumeFundingRequest =
   43     CreateOrUpdateVolumeFundingRequest [T.Text]
   44 
   45 postVolumeFunding :: ActionRoute (Id Volume, Id Funder)
   46 postVolumeFunding = action POST (pathJSON >/> pathId </> pathId) $ \(vi, fi) -> withAuth $ do
   47   v <- getVolume PermissionEDIT vi
   48   f <- maybeAction =<< lookupFunderRef fi
   49   CreateOrUpdateVolumeFundingRequest a <- runForm Nothing $ do
   50     csrfForm
   51     CreateOrUpdateVolumeFundingRequest <$> ("awards" .:> filter (not . T.null) <$> withSubDeforms (\_ -> deform))
   52   let resp@(AddVolumeFundingResponse fa) = AddVolumeFundingResponse (Funding f a)
   53   _ <- changeVolumeFunding v fa
   54   return $ okResponse [] $ JSON.pairs $ (fundingJSON . avfUnwrap) resp
   55 
   56 -- | Body of add volume funding response
   57 newtype AddVolumeFundingResponse = AddVolumeFundingResponse { avfUnwrap :: Funding }
   58 
   59 deleteVolumeFunder :: ActionRoute (Id Volume, Id Funder)
   60 deleteVolumeFunder = action DELETE (pathJSON >/> pathId </> pathId) $ \(vi, fi) -> withAuth $ do
   61   guardVerfHeader
   62   v <- getVolume PermissionEDIT vi
   63   _ <- removeVolumeFunder v fi
   64   return $ okResponse [] $ JSON.recordEncoding $ volumeJSONSimple v