1 {-# LANGUAGE RecordWildCards, OverloadedStrings, DataKinds #-} 2 module Model.Funding 3 ( module Model.Funding.Types 4 , lookupFunder 5 , findFunders 6 , addFunder 7 , lookupVolumeFunding 8 , changeVolumeFunding 9 , removeVolumeFunder 10 , funderJSON 11 , fundingJSON 12 ) where 13 14 import Data.Monoid ((<>)) 15 import qualified Data.Text as T 16 import Database.PostgreSQL.Typed.Query 17 import Database.PostgreSQL.Typed.Types 18 import qualified Data.ByteString 19 import Data.ByteString (ByteString) 20 import qualified Data.String 21 22 import qualified JSON 23 import Service.DB 24 import Model.SQL 25 import Model.Id.Types 26 import Model.Volume.Types 27 import Model.Funding.Types 28 -- import Model.Funding.SQL 29 30 lookupFunder :: MonadDB c m => Id Funder -> m (Maybe Funder) 31 lookupFunder fi = do 32 let _tenv_a13FG = unknownPGTypeEnv 33 rows <- dbQuery1 -- (selectQuery selectFunder "WHERE funder.fundref_id = ${fi}") 34 (mapQuery 35 ((\ _p_a13FH -> 36 Data.ByteString.concat 37 [Data.String.fromString 38 "SELECT funder.fundref_id,funder.name FROM funder WHERE funder.fundref_id = ", 39 pgEscapeParameter 40 _tenv_a13FG (PGTypeProxy :: PGTypeName "bigint") _p_a13FH]) 41 fi) 42 (\ [_cfundref_id_a13FI, _cname_a13FJ] 43 -> (pgDecodeColumnNotNull 44 _tenv_a13FG 45 (PGTypeProxy :: PGTypeName "bigint") 46 _cfundref_id_a13FI, 47 pgDecodeColumnNotNull 48 _tenv_a13FG (PGTypeProxy :: PGTypeName "text") _cname_a13FJ))) 49 pure 50 (fmap 51 (\ (vid_a13Ft, vname_a13Fu) -> Funder vid_a13Ft vname_a13Fu) 52 rows) 53 54 findFunders :: MonadDB c m => T.Text -> m [Funder] 55 findFunders q = do 56 let _tenv_a1vMY = unknownPGTypeEnv 57 rows <- dbQuery -- (selectQuery selectFunder "WHERE funder.name ILIKE '%' || ${q} || '%'") 58 (mapQuery 59 ((\ _p_a1vMZ -> 60 Data.ByteString.concat 61 [Data.String.fromString 62 "SELECT funder.fundref_id,funder.name FROM funder WHERE funder.name ILIKE '%' || ", 63 pgEscapeParameter 64 _tenv_a1vMY (PGTypeProxy :: PGTypeName "text") _p_a1vMZ, 65 Data.String.fromString " || '%'"]) 66 q) 67 (\ [_cfundref_id_a1vN0, _cname_a1vN1] 68 -> (pgDecodeColumnNotNull 69 _tenv_a1vMY 70 (PGTypeProxy :: PGTypeName "bigint") 71 _cfundref_id_a1vN0, 72 pgDecodeColumnNotNull 73 _tenv_a1vMY (PGTypeProxy :: PGTypeName "text") _cname_a1vN1))) 74 pure 75 (fmap 76 (\(vid_a1vMW, vname_a1vMX) -> Funder vid_a1vMW vname_a1vMX) 77 rows) 78 79 addFunder :: MonadDB c m => Funder -> m () 80 addFunder f = 81 dbExecute1' --[pgSQL|INSERT INTO funder (fundref_id, name) VALUES (${funderId f}, ${funderName f})|] 82 (mapQuery 83 (Data.ByteString.concat 84 [Data.String.fromString 85 "INSERT INTO funder (fundref_id, name) VALUES (", 86 Database.PostgreSQL.Typed.Types.pgEscapeParameter 87 unknownPGTypeEnv 88 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 89 Database.PostgreSQL.Typed.Types.PGTypeName "bigint") 90 (funderId f), 91 Data.String.fromString ", ", 92 Database.PostgreSQL.Typed.Types.pgEscapeParameter 93 unknownPGTypeEnv 94 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 95 Database.PostgreSQL.Typed.Types.PGTypeName "text") 96 (funderName f), 97 Data.String.fromString ")"]) 98 (\[] -> ())) 99 100 lookupVolumeFunding :: (MonadDB c m) => Volume -> m [Funding] 101 lookupVolumeFunding vol = do 102 let _tenv_a13pg = unknownPGTypeEnv 103 rows <- dbQuery -- (selectQuery selectVolumeFunding "WHERE volume_funding.volume = ${volumeId $ volumeRow vol}") 104 (mapQuery 105 ((\ _p_a13ph -> 106 Data.ByteString.concat 107 [Data.String.fromString 108 "SELECT volume_funding.awards,funder.fundref_id,funder.name FROM volume_funding JOIN funder ON volume_funding.funder = funder.fundref_id WHERE volume_funding.volume = ", 109 pgEscapeParameter 110 _tenv_a13pg (PGTypeProxy :: PGTypeName "integer") _p_a13ph]) 111 (volumeId $ volumeRow vol)) 112 (\ [_cawards_a13pi, _cfundref_id_a13pj, _cname_a13pk] 113 -> (pgDecodeColumnNotNull 114 _tenv_a13pg (PGTypeProxy :: PGTypeName "text[]") _cawards_a13pi, 115 pgDecodeColumnNotNull 116 _tenv_a13pg 117 (PGTypeProxy :: PGTypeName "bigint") 118 _cfundref_id_a13pj, 119 pgDecodeColumnNotNull 120 _tenv_a13pg (PGTypeProxy :: PGTypeName "text") _cname_a13pk))) 121 pure 122 (fmap 123 (\ (vawards_a13n8, vid_a13n9, vname_a13na) 124 -> ($) 125 (makeFunding vawards_a13n8) 126 (Funder vid_a13n9 vname_a13na)) 127 rows) 128 129 changeVolumeFunding :: MonadDB c m => Volume -> Funding -> m Bool 130 changeVolumeFunding v Funding{..} = 131 (0 <) . fst <$> updateOrInsert 132 -- [pgSQL|UPDATE volume_funding SET awards = ${a} WHERE volume = ${volumeId $ volumeRow v} AND funder = ${funderId fundingFunder}|] 133 (mapQuery 134 (Data.ByteString.concat 135 [Data.String.fromString "UPDATE volume_funding SET awards = ", 136 Database.PostgreSQL.Typed.Types.pgEscapeParameter 137 unknownPGTypeEnv 138 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 139 Database.PostgreSQL.Typed.Types.PGTypeName "text[]") 140 a, 141 Data.String.fromString " WHERE volume = ", 142 Database.PostgreSQL.Typed.Types.pgEscapeParameter 143 unknownPGTypeEnv 144 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 145 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 146 (volumeId $ volumeRow v), 147 Data.String.fromString " AND funder = ", 148 Database.PostgreSQL.Typed.Types.pgEscapeParameter 149 unknownPGTypeEnv 150 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 151 Database.PostgreSQL.Typed.Types.PGTypeName "bigint") 152 (funderId fundingFunder)]) 153 (\[] -> ())) 154 -- [pgSQL|INSERT INTO volume_funding (volume, funder, awards) VALUES (${volumeId $ volumeRow v}, ${funderId fundingFunder}, ${a})|] 155 (mapQuery 156 (Data.ByteString.concat 157 [Data.String.fromString 158 "INSERT INTO volume_funding (volume, funder, awards) VALUES (", 159 Database.PostgreSQL.Typed.Types.pgEscapeParameter 160 unknownPGTypeEnv 161 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 162 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 163 (volumeId $ volumeRow v), 164 Data.String.fromString ", ", 165 Database.PostgreSQL.Typed.Types.pgEscapeParameter 166 unknownPGTypeEnv 167 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 168 Database.PostgreSQL.Typed.Types.PGTypeName "bigint") 169 (funderId fundingFunder), 170 Data.String.fromString ", ", 171 Database.PostgreSQL.Typed.Types.pgEscapeParameter 172 unknownPGTypeEnv 173 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 174 Database.PostgreSQL.Typed.Types.PGTypeName "text[]") 175 a, 176 Data.String.fromString ")"]) 177 (\[] -> ())) 178 -- (volumeId $ volumeRow v) (funderId fundingFunder) a 179 where a = map Just fundingAwards 180 181 mapQuery :: ByteString -> ([PGValue] -> a) -> PGSimpleQuery a 182 mapQuery qry mkResult = 183 fmap mkResult (rawPGSimpleQuery qry) 184 185 removeVolumeFunder :: MonadDB c m => Volume -> Id Funder -> m Bool 186 removeVolumeFunder v f = 187 dbExecute1 -- [pgSQL|DELETE FROM volume_funding WHERE volume = ${volumeId $ volumeRow v} AND funder = ${f}|] 188 (mapQuery 189 (Data.ByteString.concat 190 [Data.String.fromString 191 "DELETE FROM volume_funding WHERE volume = ", 192 Database.PostgreSQL.Typed.Types.pgEscapeParameter 193 unknownPGTypeEnv 194 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 195 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 196 (volumeId $ volumeRow v), 197 Data.String.fromString " AND funder = ", 198 Database.PostgreSQL.Typed.Types.pgEscapeParameter 199 unknownPGTypeEnv 200 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 201 Database.PostgreSQL.Typed.Types.PGTypeName "bigint") 202 f]) 203 (\[] -> ())) 204 -- (volumeId $ volumeRow v) f 205 206 funderJSON :: JSON.ToObject o => Funder -> o 207 funderJSON Funder{..} = 208 "id" JSON..= funderId 209 <> "name" JSON..= funderName 210 211 fundingJSON :: JSON.ToNestedObject o u => Funding -> o 212 fundingJSON Funding{..} = 213 "funder" JSON..=. funderJSON fundingFunder 214 <> "awards" JSON..= fundingAwards