git.iko.soy/rel8
on 134ddcf help sign in
rel8/src/Rel8/Statement/Update.hs
126 lines 4.0 kB history raw
1{-# language GADTs #-}
2{-# language NamedFieldPuns #-}
3{-# language ScopedTypeVariables #-}
4{-# language StandaloneKindSignatures #-}
5{-# language TypeApplications #-}
7module Rel8.Statement.Update
8 ( Update(..)
9 , update
10 )
11where
13-- base
14import Control.Exception ( throwIO )
15import Control.Monad ( (>=>) )
16import Data.Kind ( Type )
17import Prelude
19-- hasql
20import Hasql.Connection ( Connection )
21import qualified Hasql.Decoders as Hasql
22import qualified Hasql.Encoders as Hasql
23import qualified Hasql.Session as Hasql
24import qualified Hasql.Statement as Hasql
26-- opaleye
27import qualified Opaleye.Internal.Manipulation as Opaleye
29-- profunctors
30import Data.Profunctor ( lmap )
32-- rel8
33import Rel8.Expr ( Expr )
34import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
35import Rel8.Schema.Table ( TableSchema )
36import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )
37import Rel8.Table ( fromColumns, toColumns )
38import Rel8.Table.Insert ( toInsert )
39import Rel8.Table.Opaleye ( table, unpackspec )
40import Rel8.Table.Recontextualize ( Selects )
41import Rel8.Table.Serialize ( Serializable, parse )
43-- text
44import qualified Data.Text as Text
45import Data.Text.Encoding ( encodeUtf8 )
48-- | The constituent parts of an @UPDATE@ statement.
49type Update :: Type -> Type
50data Update a where
51 Update :: Selects names exprs =>
52 { target :: TableSchema names
53 -- ^ Which table to update.
54 , set :: exprs -> exprs
55 -- ^ How to update each selected row.
56 , updateWhere :: exprs -> Expr Bool
57 -- ^ Which rows to select for update.
58 , returning :: Returning names a
59 -- ^ What to return from the @UPDATE@ statement.
60 }
61 -> Update a
64-- | Run an @UPDATE@ statement.
65--
66-- >>> mapM_ print =<< select c (each projectSchema)
67-- Project {projectAuthorId = 1, projectName = "rel8"}
68-- Project {projectAuthorId = 2, projectName = "aeson"}
69-- Project {projectAuthorId = 2, projectName = "text"}
70--
71-- >>> :{
72-- update c Update
73-- { target = projectSchema
74-- , set = \p -> p { projectName = "Rel8!" }
75-- , updateWhere = \p -> projectName p ==. lit "rel8"
76-- , returning = NumberOfRowsAffected
77-- }
78-- :}
79-- 1
80--
81-- >>> mapM_ print =<< select c (each projectSchema)
82-- Project {projectAuthorId = 2, projectName = "aeson"}
83-- Project {projectAuthorId = 2, projectName = "text"}
84-- Project {projectAuthorId = 1, projectName = "Rel8!"}
85update :: Update a -> Connection -> IO a
86update Update {target, set, updateWhere, returning} =
87 case returning of
88 NumberOfRowsAffected -> Hasql.run session >=> either throwIO pure
89 where
90 session = Hasql.statement () statement
91 statement = Hasql.Statement bytes params decode prepare
92 bytes = encodeUtf8 $ Text.pack sql
93 params = Hasql.noParams
94 decode = Hasql.rowsAffected
95 prepare = False
96 sql = Opaleye.arrangeUpdateSql target' set' where'
97 where
98 target' = lmap toInsert $ table $ toColumns <$> target
99 set' = toColumns . set . fromColumns
100 where' = toColumn . toPrimExpr . updateWhere . fromColumns
102 Projection project -> Hasql.run session >=> either throwIO pure
103 where
104 session = Hasql.statement () statement
105 statement = Hasql.Statement bytes params decode prepare
106 bytes = encodeUtf8 $ Text.pack sql
107 params = Hasql.noParams
108 decode = decoder project
109 prepare = False
110 sql =
111 Opaleye.arrangeUpdateReturningSql
112 unpackspec
113 target'
114 set'
115 where'
116 project'
117 where
118 target' = lmap toInsert $ table $ toColumns <$> target
119 set' = toColumns . set . fromColumns
120 where' = toColumn . toPrimExpr . updateWhere . fromColumns
121 project' = toColumns . project . fromColumns
123 where
124 decoder :: forall exprs projection a. Serializable projection a
125 => (exprs -> projection) -> Hasql.Result [a]
126 decoder _ = Hasql.rowList (parse @projection @a)