02a7f54 · squeal · git.iko.soy

105

106 manipulateParams

107 :: ToParams x params

108− => Manipulation schema params ys -> x -> pq (Maybe (Result ys))

108+ => Manipulation schema params ys -> x -> pq (Result ys)

109 default manipulateParams

110 :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

111 => ToParams x params

112− => Manipulation schema params ys -> x -> pq (Maybe (Result ys))

112+ => Manipulation schema params ys -> x -> pq (Result ys)

113 manipulateParams manipulation params = lift $

114 manipulateParams manipulation params

115

116− manipulate :: Manipulation schema '[] ys -> pq (Maybe (Result ys))

116+ manipulate :: Manipulation schema '[] ys -> pq (Result ys)

117 manipulate statement = manipulateParams statement ()

118

119 queryParams

120 :: ToParams x params

121− => Query schema params ys -> x -> pq (Maybe (Result ys))

121+ => Query schema params ys -> x -> pq (Result ys)

122 queryParams = manipulateParams . queryStatement

123

124− query :: Query schema '[] ys -> pq (Maybe (Result ys))

124+ query :: Query schema '[] ys -> pq (Result ys)

125 query q = queryParams q ()

126

127 traversePrepared

128 :: (ToParams x params, Traversable list)

129− => Manipulation schema params ys -> list x -> pq (list (Maybe (Result ys)))

129+ => Manipulation schema params ys -> list x -> pq (list (Result ys))

130 default traversePrepared

131 :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

132 => (ToParams x params, Traversable list)

133− => Manipulation schema params ys -> list x -> pq (list (Maybe (Result ys)))

133+ => Manipulation schema params ys -> list x -> pq (list (Result ys))

134 traversePrepared manipulation params = lift $

135 traversePrepared manipulation params

136

137 forPrepared

138 :: (ToParams x params, Traversable list)

139− => list x -> Manipulation schema params ys -> pq (list (Maybe (Result ys)))

139+ => list x -> Manipulation schema params ys -> pq (list (Result ys))

140 forPrepared = flip traversePrepared

141

142 traversePrepared_

154 => list x -> Manipulation schema params ys -> pq ()

155 forPrepared_ = flip traversePrepared_

156

157− connectPoll :: pq LibPQ.PollingStatus

157+ liftPQ :: (LibPQ.Connection -> IO a) -> pq a

158+ default liftPQ

159+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

160+ => (LibPQ.Connection -> IO a) -> pq a

161+ liftPQ = lift . liftPQ

158

162

159instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where

163instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where

160

164

164 let

168 let

165 toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)

169 toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)

166 params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))

170 params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))

167− result <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary

171+ resultMaybe <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary

172+ case resultMaybe of

173+ Nothing -> error

174+ "manipulateParams: LibPQ.execParams returned no results"

168− return (Result <$> result, Connection conn)

175+ Just result -> return (Result result, Connection conn)

169

176

170 traversePrepared

177 traversePrepared

171 (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =

178 (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =

172 PQ $ \ (Connection conn) -> do

179 PQ $ \ (Connection conn) -> do

173 let temp = "temporary_statement"

180 let temp = "temporary_statement"

174− _prepResult <- liftBase $ LibPQ.prepare conn temp q Nothing

181+ prepResultMaybe <- liftBase $ LibPQ.prepare conn temp q Nothing

182+ case prepResultMaybe of

183+ Nothing -> error

184+ "traversePrepared: LibPQ.prepare returned no results"

185+ Just _prepResult -> return () -- todo: check status of prepResult

175 results <- for list $ \ params -> do

186 results <- for list $ \ params -> do

176 let

187 let

177 toParam' bytes = (bytes,LibPQ.Binary)

188 toParam' bytes = (bytes,LibPQ.Binary)

178 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))

189 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))

179− result <- liftBase $

190+ resultMaybe <- liftBase $

180 LibPQ.execPrepared conn temp params' LibPQ.Binary

191 LibPQ.execPrepared conn temp params' LibPQ.Binary

192+ case resultMaybe of

193+ Nothing -> error

194+ "traversePrepared: LibPQ.execParams returned no results"

181− return $ Result <$> result

195+ Just result -> return $ Result result

182− _deallocResult <- liftBase $

196+ deallocResultMaybe <- liftBase $

183 LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

197 LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

198+ case deallocResultMaybe of

199+ Nothing -> error

200+ "traversePrepared: LibPQ.exec DEALLOCATE returned no results"

201+ Just _deallocResult -> return ()

202+ -- todo: check status of deallocResult

184 return (results, Connection conn)

203 return (results, Connection conn)

185

204

186 traversePrepared_

205 traversePrepared_

187 (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =

206 (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =

188 PQ $ \ (Connection conn) -> do

207 PQ $ \ (Connection conn) -> do

189 let temp = "temporary_statement"

208 let temp = "temporary_statement"

190− _prepResult <- liftBase $ LibPQ.prepare conn temp q Nothing

209+ prepResultMaybe <- liftBase $ LibPQ.prepare conn temp q Nothing

210+ case prepResultMaybe of

211+ Nothing -> error

212+ "traversePrepared_: LibPQ.prepare returned no results"

213+ Just _prepResult -> return () -- todo: check status of prepResult

191 for_ list $ \ params -> do

214 for_ list $ \ params -> do

192 let

215 let

193 toParam' bytes = (bytes,LibPQ.Binary)

216 toParam' bytes = (bytes,LibPQ.Binary)

194 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))

217 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))

195− _result <- liftBase $

218+ resultMaybe <- liftBase $

196 LibPQ.execPrepared conn temp params' LibPQ.Binary

219 LibPQ.execPrepared conn temp params' LibPQ.Binary

220+ case resultMaybe of

221+ Nothing -> error

222+ "traversePrepared_: LibPQ.execParams returned no results"

197− return ()

223+ Just _result -> return ()

198− _deallocResult <- liftBase $

224+ deallocResultMaybe <- liftBase $

199 LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

225 LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

226+ case deallocResultMaybe of

227+ Nothing -> error

228+ "traversePrepared: LibPQ.exec DEALLOCATE returned no results"

229+ Just _deallocResult -> return ()

230+ -- todo: check status of deallocResult

200 return ((), Connection conn)

231 return ((), Connection conn)

201

232

202− connectPoll = PQ $ \ (Connection conn) -> do

233+ liftPQ pq = PQ $ \ (Connection conn) -> do

203− pollingStatus <- liftBase $ LibPQ.connectPoll conn

234+ y <- liftBase $ pq conn

204− return (pollingStatus, Connection conn)

235+ return (y, Connection conn)

205

236

206instance Monad m => Applicative (PQ schema schema m) where

237instance Monad m => Applicative (PQ schema schema m) where

207 pure x = PQ $ \ conn -> pure (x, conn)

238 pure x = PQ $ \ conn -> pure (x, conn)

274 (RowNumber r)

305 (RowNumber r)

275 (UnsafeColumnNumber c :: ColumnNumber n columns colty)

306 (UnsafeColumnNumber c :: ColumnNumber n columns colty)

276 (Result result)

307 (Result result)

277− = fromColumnValue @colty . K <$>

308+ = fmap (fromColumnValue @colty . K) $ liftBase $ do

309+ numRows <- LibPQ.ntuples result

310+ when (numRows < r) $ error $

311+ "getValue: expected at least " <> show r <> "rows but only saw "

312+ <> show numRows

278− liftBase (LibPQ.getvalue result r c)

313+ LibPQ.getvalue result r c

279

314

280getRow

315getRow

281 :: (FromRow columns y, MonadBase IO io)

316 :: (FromRow columns y, MonadBase IO io)

282 => RowNumber -> Result columns -> io y

317 => RowNumber -> Result columns -> io y

283−getRow (RowNumber r) (Result result :: Result columns) = do

318+getRow (RowNumber r) (Result result :: Result columns) = liftBase $do

319+ numRows <- LibPQ.ntuples result

320+ when (numRows < r) $ error $

321+ "getRow: expected at least " <> show r <> "rows but only saw "

322+ <> show numRows

284 let len = fromIntegral (lengthSList (Proxy @columns))

323 let len = fromIntegral (lengthSList (Proxy @columns))

324+ numCols <- LibPQ.nfields result

325+ when (numCols /= len) $ error $

326+ "getRow: expected at least " <> show len <> "columns but only saw "

327+ <> show numCols

285− row' <- traverse (liftBase . LibPQ.getvalue result r) [0 .. len - 1]

328+ row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

286 case fromList row' of

329 case fromList row' of

287 Nothing -> error "getRow: found unexpected length"

330 Nothing -> error "getRow: found unexpected length"

288 Just row -> return $ fromRow @columns row

331 Just row -> return $ fromRow @columns row

332+

333+nextRow

334+ :: (FromRow columns y, MonadBase IO io)

335+ => Result columns -> RowNumber -> io (Maybe (RowNumber,y))

336+nextRow (Result result :: Result columns) (RowNumber r) = liftBase $ do

337+ numRows <- LibPQ.ntuples result -- todo: cache this

338+ if numRows < r then return Nothing else do

339+ let len = fromIntegral (lengthSList (Proxy @columns))

340+ numCols <- LibPQ.nfields result -- todo: cache this

341+ when (numCols /= len) $ error $

342+ "nextRow: expected at least " <> show len <> "columns but only saw "

343+ <> show numCols

344+ row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

345+ case fromList row' of

346+ Nothing -> error "nextRow: found unexpected length"

347+ Just row -> return $ Just (RowNumber (r+1), fromRow @columns row)

348+

349+getRows :: (FromRow columns y, MonadBase IO io) => Result columns -> io [y]

350+getRows (Result result :: Result columns) = liftBase $ do

351+ let len = fromIntegral (lengthSList (Proxy @columns))

352+ numCols <- LibPQ.nfields result

353+ when (numCols /= len) $ error $

354+ "getRow: expected at least " <> show len <> "columns but only saw "

355+ <> show numCols

356+ numRows <- LibPQ.ntuples result

357+ for [0 .. numRows - 1] $ \ r -> do

358+ row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

359+ case fromList row' of

360+ Nothing -> error "getRows: found unexpected length"

361+ Just row -> return $ fromRow @columns row

362+

363+getRowMaybe

364+ :: (FromRow columns y, MonadBase IO io)

365+ => RowNumber -> Result columns -> io (Maybe y)

366+getRowMaybe (RowNumber r) (Result result :: Result columns) = liftBase $do

367+ numRows <- LibPQ.ntuples result

368+ if numRows < r then return Nothing else do

369+ let len = fromIntegral (lengthSList (Proxy @columns))

370+ numCols <- LibPQ.nfields result

371+ when (numCols /= len) $ error $

372+ "getRow: expected at least " <> show len <> "columns but only saw "

373+ <> show numCols

374+ row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

375+ case fromList row' of

376+ Nothing -> error "getRow: found unexpected length"

377+ Just row -> return . Just $ fromRow @columns row