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