git.iko.soy/rel8
on 83edc03 help sign in
rel8/src/Rel8/Statement/Update.hs
100 lines 3.1 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 )
48type Update :: Type -> Type
49data Update a where
50 Update :: Selects names exprs =>
51 { target :: TableSchema names
52 , set :: exprs -> exprs
53 , updateWhere :: exprs -> Expr Bool
54 , returning :: Returning names a
55 }
56 -> Update a
59update :: Update a -> Connection -> IO a
60update Update {target, set, updateWhere, returning} =
61 case returning of
62 NumberOfRowsAffected -> Hasql.run session >=> either throwIO pure
63 where
64 session = Hasql.statement () statement
65 statement = Hasql.Statement bytes params decode prepare
66 bytes = encodeUtf8 $ Text.pack sql
67 params = Hasql.noParams
68 decode = Hasql.rowsAffected
69 prepare = False
70 sql = Opaleye.arrangeUpdateSql target' set' where'
71 where
72 target' = lmap toInsert $ table $ toColumns <$> target
73 set' = toColumns . set . fromColumns
74 where' = toColumn . toPrimExpr . updateWhere . fromColumns
76 Projection project -> Hasql.run session >=> either throwIO pure
77 where
78 session = Hasql.statement () statement
79 statement = Hasql.Statement bytes params decode prepare
80 bytes = encodeUtf8 $ Text.pack sql
81 params = Hasql.noParams
82 decode = decoder project
83 prepare = False
84 sql =
85 Opaleye.arrangeUpdateReturningSql
86 unpackspec
87 target'
88 set'
89 where'
90 project'
91 where
92 target' = lmap toInsert $ table $ toColumns <$> target
93 set' = toColumns . set . fromColumns
94 where' = toColumn . toPrimExpr . updateWhere . fromColumns
95 project' = toColumns . project . fromColumns
97 where
98 decoder :: forall exprs projection a. Serializable projection a
99 => (exprs -> projection) -> Hasql.Result [a]
100 decoder _ = Hasql.rowList (parse @projection @a)