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