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