{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE Arrows #-}

module Tedious.Handler (
  withDoc,
  withDoc',
  errorHandler,
  authFail,
  audit,
  list,
  list',
  get,
  get',
  add,
  add',
  dup,
  dup',
  upd,
  upd',
  del
) where

import Control.Arrow (returnA)
import Control.Lens ((^.))
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Pool (Pool, withResource)
import Data.Profunctor.Product.Default (Default)
import Data.Text (Text, pack)
import Data.Time (getCurrentTime)
import Data.Tuple.All (Sel1 (..))
import Database.PostgreSQL.Simple (Connection)
import Effectful (Eff, IOE, MonadIO (..), (:>))
import Effectful.Error.Dynamic (throwError)
import Effectful.Reader.Dynamic (Reader, asks)
import Network.HTTP.Types qualified as HTTP
import Opaleye (DefaultFromField, Delete (Delete, dReturning, dTable, dWhere), Field, FromFields, Insert (Insert, iOnConflict, iReturning, iRows, iTable), Order, Select, SqlBool, SqlInt8, Table, Unpackspec, Update (Update, uReturning, uTable, uUpdateWith, uWhere), countRows, limit, offset, orderBy, rCount, rReturning, runDelete, runInsert, runSelect, runUpdate, selectTable, sqlStrictText, sqlUTCTime, toNullable, where_, (.==))
import Opaleye.Internal.Table (tableIdentifier)
import Tedious.Entity (Err (Err), Page (Page), PageI (_pageIFilter, _pageIPage), PageO (PageO), Rep, SysOper' (..), SysOperTargetName, catchRep, fillPage, pageIndex, pageSize, rep, repErr, repOk, sysOperTable)
import WebGear.Core (BasicAuthError (..), Body, Description, Gets, Handler (arrM, setDescription, setSummary), HasTrait (from), HaveTraits, JSON (JSON), Middleware, PathVar, PlainText (..), Request, RequestHandler, RequiredResponseHeader, Response, Sets, StdHandler, Summary, With, pick, requestBody, respondA, (<<<))

withDoc :: (Handler h m) => Summary -> Description -> Middleware h ts ts
withDoc :: forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
Handler h m =>
Summary -> Description -> Middleware h ts ts
withDoc Summary
summ Description
desc RequestHandler h ts
handler = Description -> h Response Response
forall a. Description -> h a a
forall (h :: * -> * -> *) (m :: * -> *) a.
Handler h m =>
Description -> h a a
setDescription Description
desc h Response Response -> RequestHandler h ts -> RequestHandler h ts
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< Summary -> h Response Response
forall a. Summary -> h a a
forall (h :: * -> * -> *) (m :: * -> *) a.
Handler h m =>
Summary -> h a a
setSummary Summary
summ h Response Response -> RequestHandler h ts -> RequestHandler h ts
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< RequestHandler h ts
handler

withDoc' :: (Handler h m) => Summary -> Middleware h ts ts
withDoc' :: forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
Handler h m =>
Summary -> Middleware h ts ts
withDoc' Summary
summ RequestHandler h ts
handler = Summary -> h Response Response
forall a. Summary -> h a a
forall (h :: * -> * -> *) (m :: * -> *) a.
Handler h m =>
Summary -> h a a
setSummary Summary
summ h Response Response -> RequestHandler h ts -> RequestHandler h ts
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< RequestHandler h ts
handler

errorHandler ::
  ( Show e,
    StdHandler h m,
    Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep ())]
  ) =>
  h (Request `With` ts, e) Response
errorHandler :: forall e (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(Show e, StdHandler h m,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text,
     Body JSON (Rep ())]) =>
h (With Request ts, e) Response
errorHandler = proc (With Request ts
_, e
err) -> Status -> JSON -> h (Rep ()) Response
forall body mt (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
 Sets
   h
   '[Status, Body mt body,
     RequiredResponseHeader "Content-Type" Text],
 MIMEType mt) =>
Status -> mt -> h body Response
respondA Status
HTTP.ok200 JSON
JSON -< (Natural -> Text -> Rep ()
forall a. Natural -> Text -> Rep a
repErr Natural
1 (String -> Text
pack (String -> Text) -> (e -> String) -> e -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
forall a. Show a => a -> String
show (e -> Text) -> e -> Text
forall a b. (a -> b) -> a -> b
$ e
err) :: Rep ())

-- authFail ::

--   ( StdHandler h App,

--     Sets h '[RequiredResponseHeader "WWW-Authenticate" Text]

--   ) =>

--   h (Request `With` ts, BasicAuthError ()) Response

-- authFail = respondUnauthorized "Basic" "MyRealm"


authFail ::
  ( StdHandler h (Eff es)
  ) =>
  h (Request `With` ts, BasicAuthError ()) Response
authFail :: forall (h :: * -> * -> *) (es :: [Effect]) (ts :: [*]).
StdHandler h (Eff es) =>
h (With Request ts, BasicAuthError ()) Response
authFail = proc (With Request ts
_request, BasicAuthError ()
err) -> case BasicAuthError ()
err of
  BasicAuthAttributeError () ->
    Status -> PlainText -> h Text Response
forall body mt (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
 Sets
   h
   '[Status, Body mt body,
     RequiredResponseHeader "Content-Type" Text],
 MIMEType mt) =>
Status -> mt -> h body Response
respondA Status
HTTP.forbidden403 PlainText
PlainText -< Text
"Forbidden" :: Text
  BasicAuthError ()
_ ->
    Status -> PlainText -> h Text Response
forall body mt (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
 Sets
   h
   '[Status, Body mt body,
     RequiredResponseHeader "Content-Type" Text],
 MIMEType mt) =>
Status -> mt -> h body Response
respondA Status
HTTP.unauthorized401 PlainText
PlainText -< Text
"Unauthorized" :: Text

audit ::
  forall eff env es h ts. -- eff effects (app env) arrow traits

  ( Reader env :> es,
    IOE :> es,
    eff ~ Eff es,
    StdHandler h eff
  ) =>
  (env -> Pool Connection) ->
  Maybe Text ->
  (RequestHandler h ts, SysOper') ->
  RequestHandler h ts
audit :: forall (eff :: * -> *) env (es :: [Effect]) (h :: * -> * -> *)
       (ts :: [*]).
(Reader env :> es, IOE :> es, eff ~ Eff es, StdHandler h eff) =>
(env -> Pool Connection)
-> Maybe Text
-> (RequestHandler h ts, SysOper')
-> RequestHandler h ts
audit env -> Pool Connection
envPool Maybe Text
user (RequestHandler h ts
handler, SysOper'
oper) =
  proc With Request ts
request -> do
    Response
res <- RequestHandler h ts
handler -< With Request ts
request
    (() -> Eff es [()]) -> h () [()]
forall a b. (a -> Eff es b) -> h a b
forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM
      ( Eff es [()] -> () -> Eff es [()]
forall a b. a -> b -> a
const (Eff es [()] -> () -> Eff es [()])
-> Eff es [()] -> () -> Eff es [()]
forall a b. (a -> b) -> a -> b
$ do
          Pool Connection
pool <- (env -> Pool Connection) -> Eff es (Pool Connection)
forall r (es :: [Effect]) a.
(HasCallStack, Reader r :> es) =>
(r -> a) -> Eff es a
asks env -> Pool Connection
envPool
          IO [()] -> Eff es [()]
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [()] -> Eff es [()])
-> ((Connection -> IO [()]) -> IO [()])
-> (Connection -> IO [()])
-> Eff es [()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool Connection -> (Connection -> IO [()]) -> IO [()]
forall a r. Pool a -> (a -> IO r) -> IO r
withResource Pool Connection
pool ((Connection -> IO [()]) -> Eff es [()])
-> (Connection -> IO [()]) -> Eff es [()]
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
            Connection -> Insert [()] -> IO [()]
forall haskells. Connection -> Insert haskells -> IO haskells
runInsert
              Connection
conn
              Insert
                { iTable :: Table
  (Maybe (Field SqlInt8), Maybe (FieldNullable SqlText),
   Field SqlText, Field SqlText, Maybe (FieldNullable SqlText),
   Maybe (Field SqlTimestamptz))
  (Field SqlInt8, FieldNullable SqlText, Field SqlText,
   Field SqlText, FieldNullable SqlText, Field SqlTimestamptz)
iTable = Table
  (Maybe (Field SqlInt8), Maybe (FieldNullable SqlText),
   Field SqlText, Field SqlText, Maybe (FieldNullable SqlText),
   Maybe (Field SqlTimestamptz))
  (Field SqlInt8, FieldNullable SqlText, Field SqlText,
   Field SqlText, FieldNullable SqlText, Field SqlTimestamptz)
sysOperTable,
                  iRows :: [(Maybe (Field SqlInt8), Maybe (FieldNullable SqlText),
  Field SqlText, Field SqlText, Maybe (FieldNullable SqlText),
  Maybe (Field SqlTimestamptz))]
iRows =
                    [ ( Maybe (Field SqlInt8)
forall a. Maybe a
Nothing,
                        Field SqlText -> FieldNullable SqlText
forall a. Field a -> FieldNullable a
toNullable (Field SqlText -> FieldNullable SqlText)
-> (Text -> Field SqlText) -> Text -> FieldNullable SqlText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Field SqlText
sqlStrictText (Text -> FieldNullable SqlText)
-> Maybe Text -> Maybe (FieldNullable SqlText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
user,
                        Text -> Field SqlText
sqlStrictText (Text -> Field SqlText)
-> (SysOper' -> Text) -> SysOper' -> Field SqlText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SysOper' -> Text
_sysOper'Name (SysOper' -> Field SqlText) -> SysOper' -> Field SqlText
forall a b. (a -> b) -> a -> b
$ SysOper'
oper,
                        Text -> Field SqlText
sqlStrictText (Text -> Field SqlText)
-> (SysOper' -> Text) -> SysOper' -> Field SqlText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SysOper' -> Text
_sysOper'Target (SysOper' -> Field SqlText) -> SysOper' -> Field SqlText
forall a b. (a -> b) -> a -> b
$ SysOper'
oper,
                        Field SqlText -> FieldNullable SqlText
forall a. Field a -> FieldNullable a
toNullable (Field SqlText -> FieldNullable SqlText)
-> (Text -> Field SqlText) -> Text -> FieldNullable SqlText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Field SqlText
sqlStrictText (Text -> FieldNullable SqlText)
-> Maybe Text -> Maybe (FieldNullable SqlText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SysOper' -> Maybe Text
_sysOper'Content SysOper'
oper,
                        Maybe (Field SqlTimestamptz)
forall a. Maybe a
Nothing
                      )
                    ],
                  iReturning :: Returning
  (Field SqlInt8, FieldNullable SqlText, Field SqlText,
   Field SqlText, FieldNullable SqlText, Field SqlTimestamptz)
  [()]
iReturning = ((Field SqlInt8, FieldNullable SqlText, Field SqlText,
  Field SqlText, FieldNullable SqlText, Field SqlTimestamptz)
 -> ())
-> Returning
     (Field SqlInt8, FieldNullable SqlText, Field SqlText,
      Field SqlText, FieldNullable SqlText, Field SqlTimestamptz)
     [()]
forall fields haskells fieldsR.
Default FromFields fields haskells =>
(fieldsR -> fields) -> Returning fieldsR [haskells]
rReturning (()
-> (Field SqlInt8, FieldNullable SqlText, Field SqlText,
    Field SqlText, FieldNullable SqlText, Field SqlTimestamptz)
-> ()
forall a b. a -> b -> a
const ()),
                  iOnConflict :: Maybe OnConflict
iOnConflict = Maybe OnConflict
forall a. Maybe a
Nothing
                }
      )
      -<
        ()
    h Response Response
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Response
res

list ::
  forall i d f ids wfs rfs r eff env es h ts. -- (record id) data (data filter) [id] (table write fields) (table read fields) (table record) eff effects (app env) arrow traits

  ( ids ~ [i],
    Integral i,
    DefaultFromField SqlInt8 i,
    Default Unpackspec rfs rfs,
    Default FromFields rfs r,
    Reader env :> es,
    IOE :> es,
    eff ~ Eff es,
    StdHandler h eff,
    Gets h '[Body JSON (PageI f)],
    Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep (PageO [d])), Body JSON (Rep ())]
  ) =>
  (env -> Pool Connection) ->
  Table wfs rfs ->
  (Maybe f -> rfs -> Field SqlBool) ->
  Order rfs ->
  (r -> d) ->
  (RequestHandler h ts, SysOper')
list :: forall i d f ids wfs rfs r (eff :: * -> *) env (es :: [Effect])
       (h :: * -> * -> *) (ts :: [*]).
(ids ~ [i], Integral i, DefaultFromField SqlInt8 i,
 Default Unpackspec rfs rfs, Default FromFields rfs r,
 Reader env :> es, IOE :> es, eff ~ Eff es, StdHandler h eff,
 Gets h '[Body JSON (PageI f)],
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text,
     Body JSON (Rep (PageO [d])), Body JSON (Rep ())]) =>
(env -> Pool Connection)
-> Table wfs rfs
-> (Maybe f -> rfs -> Field SqlBool)
-> Order rfs
-> (r -> d)
-> (RequestHandler h ts, SysOper')
list env -> Pool Connection
envPool Table wfs rfs
tbl Maybe f -> rfs -> Field SqlBool
flt Order rfs
ord r -> d
r2d =
  let handler :: RequestHandler h ts
handler = forall t mt (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(Handler h m, Get h (Body mt t)) =>
mt
-> h (With Request ts, Text) Response
-> Middleware h ts (Body mt t : ts)
requestBody @(PageI f) JSON
JSON h (With Request ts, Text) Response
forall e (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(Show e, StdHandler h m,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text,
     Body JSON (Rep ())]) =>
h (With Request ts, e) Response
errorHandler Middleware h ts (Body JSON (PageI f) : ts)
-> Middleware h ts (Body JSON (PageI f) : ts)
forall a b. (a -> b) -> a -> b
$
        proc With Request (Body JSON (PageI f) : ts)
request -> do
          let pageI :: PageI f
pageI = forall {k} (t :: k) a. Tagged t a -> a
forall t a. Tagged t a -> a
pick @(Body JSON (PageI f)) (Tagged (Body JSON (PageI f)) (PageI f) -> PageI f)
-> Tagged (Body JSON (PageI f)) (PageI f) -> PageI f
forall a b. (a -> b) -> a -> b
$ With Request (Body JSON (PageI f) : ts)
-> Tagged
     (Body JSON (PageI f)) (Attribute (Body JSON (PageI f)) Request)
forall a.
With a (Body JSON (PageI f) : ts)
-> Tagged (Body JSON (PageI f)) (Attribute (Body JSON (PageI f)) a)
forall t (ts :: [*]) a.
HasTrait t ts =>
With a ts -> Tagged t (Attribute t a)
from With Request (Body JSON (PageI f) : ts)
request
          Rep (PageO [d])
res <-
            (PageI f -> Eff es (Rep (PageO [d])))
-> h (PageI f) (Rep (PageO [d]))
forall a b. (a -> Eff es b) -> h a b
forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM
              ( \PageI f
pageI -> Eff (Error Err : es) (Rep (PageO [d])) -> Eff es (Rep (PageO [d]))
forall (es :: [Effect]) a.
Eff (Error Err : es) (Rep a) -> Eff es (Rep a)
catchRep (Eff (Error Err : es) (Rep (PageO [d]))
 -> Eff es (Rep (PageO [d])))
-> Eff (Error Err : es) (Rep (PageO [d]))
-> Eff es (Rep (PageO [d]))
forall a b. (a -> b) -> a -> b
$ do
                  let mPage :: Maybe Page
mPage = PageI f -> Maybe Page
forall a. PageI a -> Maybe Page
_pageIPage PageI f
pageI
                  Pool Connection
pool <- (env -> Pool Connection) -> Eff (Error Err : es) (Pool Connection)
forall r (es :: [Effect]) a.
(HasCallStack, Reader r :> es) =>
(r -> a) -> Eff es a
asks env -> Pool Connection
envPool
                  ([r]
rs, [Natural]
cs) <- IO ([r], [Natural]) -> Eff (Error Err : es) ([r], [Natural])
forall a. IO a -> Eff (Error Err : es) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([r], [Natural]) -> Eff (Error Err : es) ([r], [Natural]))
-> ((Connection -> IO ([r], [Natural])) -> IO ([r], [Natural]))
-> (Connection -> IO ([r], [Natural]))
-> Eff (Error Err : es) ([r], [Natural])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool Connection
-> (Connection -> IO ([r], [Natural])) -> IO ([r], [Natural])
forall a r. Pool a -> (a -> IO r) -> IO r
withResource Pool Connection
pool ((Connection -> IO ([r], [Natural]))
 -> Eff (Error Err : es) ([r], [Natural]))
-> (Connection -> IO ([r], [Natural]))
-> Eff (Error Err : es) ([r], [Natural])
forall a b. (a -> b) -> a -> b
$
                    \Connection
conn -> do
                      let sel :: SelectArr () rfs
sel = do
                            rfs
r <- Table wfs rfs -> SelectArr () rfs
forall fields a.
Default Unpackspec fields fields =>
Table a fields -> Select fields
selectTable Table wfs rfs
tbl
                            Field SqlBool -> Select ()
where_ (Field SqlBool -> Select ()) -> Field SqlBool -> Select ()
forall a b. (a -> b) -> a -> b
$ Maybe f -> rfs -> Field SqlBool
flt (PageI f -> Maybe f
forall a. PageI a -> Maybe a
_pageIFilter PageI f
pageI) rfs
r
                            rfs -> SelectArr () rfs
forall a. a -> SelectArr () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure rfs
r
                      let sel' :: SelectArr () rfs
sel' = case Maybe Page
mPage of
                            Maybe Page
Nothing -> SelectArr () rfs
sel
                            Just Page
page -> Int -> SelectArr () rfs -> SelectArr () rfs
forall a. Int -> Select a -> Select a
limit (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Int) -> Natural -> Int
forall a b. (a -> b) -> a -> b
$ Page
page Page -> Getting Natural Page Natural -> Natural
forall s a. s -> Getting a s a -> a
^. Getting Natural Page Natural
Lens' Page Natural
pageSize) (SelectArr () rfs -> SelectArr () rfs)
-> (SelectArr () rfs -> SelectArr () rfs)
-> SelectArr () rfs
-> SelectArr () rfs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SelectArr () rfs -> SelectArr () rfs
forall a. Int -> Select a -> Select a
offset (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Int) -> Natural -> Int
forall a b. (a -> b) -> a -> b
$ (Page
page Page -> Getting Natural Page Natural -> Natural
forall s a. s -> Getting a s a -> a
^. Getting Natural Page Natural
Lens' Page Natural
pageIndex Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1) Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* (Page
page Page -> Getting Natural Page Natural -> Natural
forall s a. s -> Getting a s a -> a
^. Getting Natural Page Natural
Lens' Page Natural
pageSize)) (SelectArr () rfs -> SelectArr () rfs)
-> (SelectArr () rfs -> SelectArr () rfs)
-> SelectArr () rfs
-> SelectArr () rfs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Order rfs -> SelectArr () rfs -> SelectArr () rfs
forall a. Order a -> Select a -> Select a
orderBy Order rfs
ord (SelectArr () rfs -> SelectArr () rfs)
-> SelectArr () rfs -> SelectArr () rfs
forall a b. (a -> b) -> a -> b
$ SelectArr () rfs
sel
                      [r]
rs <- Connection -> SelectArr () rfs -> IO [r]
forall fields haskells.
Default FromFields fields haskells =>
Connection -> Select fields -> IO [haskells]
runSelect Connection
conn SelectArr () rfs
sel'
                      [i]
cs <- Connection -> Select (Field SqlInt8) -> IO [i]
forall fields haskells.
Default FromFields fields haskells =>
Connection -> Select fields -> IO [haskells]
runSelect Connection
conn (Select (Field SqlInt8) -> IO [i])
-> (SelectArr () rfs -> Select (Field SqlInt8))
-> SelectArr () rfs
-> IO [i]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SelectArr () rfs -> Select (Field SqlInt8)
forall a. Select a -> Select (Field SqlInt8)
countRows (SelectArr () rfs -> IO [i]) -> SelectArr () rfs -> IO [i]
forall a b. (a -> b) -> a -> b
$ Table wfs rfs -> SelectArr () rfs
forall fields a.
Default Unpackspec fields fields =>
Table a fields -> Select fields
selectTable Table wfs rfs
tbl
                      ([r], [Natural]) -> IO ([r], [Natural])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([r]
rs, i -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (i -> Natural) -> [i] -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ids
[i]
cs :: ids))
                  let count :: Natural
count = Natural -> Maybe Natural -> Natural
forall a. a -> Maybe a -> a
fromMaybe Natural
0 ([Natural] -> Maybe Natural
forall a. [a] -> Maybe a
listToMaybe [Natural]
cs)
                  let pageO :: [d] -> PageO [d]
pageO = case Maybe Page
mPage of
                        Maybe Page
Nothing -> Page -> Natural -> [d] -> PageO [d]
forall a. Page -> Natural -> a -> PageO a
PageO (Natural -> Natural -> Page
Page Natural
1 Natural
count) Natural
count
                        Just Page
page -> Page -> Natural -> [d] -> PageO [d]
forall a. Page -> Natural -> a -> PageO a
fillPage Page
page Natural
count
                  Rep (PageO [d]) -> Eff (Error Err : es) (Rep (PageO [d]))
forall a. a -> Eff (Error Err : es) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Rep (PageO [d]) -> Eff (Error Err : es) (Rep (PageO [d])))
-> ([d] -> Rep (PageO [d]))
-> [d]
-> Eff (Error Err : es) (Rep (PageO [d]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PageO [d] -> Rep (PageO [d])
forall a. a -> Rep a
rep (PageO [d] -> Rep (PageO [d]))
-> ([d] -> PageO [d]) -> [d] -> Rep (PageO [d])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [d] -> PageO [d]
pageO ([d] -> Eff (Error Err : es) (Rep (PageO [d])))
-> [d] -> Eff (Error Err : es) (Rep (PageO [d]))
forall a b. (a -> b) -> a -> b
$ r -> d
r2d (r -> d) -> [r] -> [d]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [r]
rs
              )
              -<
                PageI f
pageI
          Status -> JSON -> h (Rep (PageO [d])) Response
forall body mt (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
 Sets
   h
   '[Status, Body mt body,
     RequiredResponseHeader "Content-Type" Text],
 MIMEType mt) =>
Status -> mt -> h body Response
respondA Status
HTTP.ok200 JSON
JSON -< Rep (PageO [d])
res
      sysOper :: SysOper'
sysOper = Text -> Text -> Maybe Text -> SysOper'
SysOper' Text
"list" (String -> Text
pack (String -> Text)
-> (Table wfs rfs -> String) -> Table wfs rfs -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableIdentifier -> String
forall a. Show a => a -> String
show (TableIdentifier -> String)
-> (Table wfs rfs -> TableIdentifier) -> Table wfs rfs -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table wfs rfs -> TableIdentifier
forall writeColumns viewColumns.
Table writeColumns viewColumns -> TableIdentifier
tableIdentifier (Table wfs rfs -> Text) -> Table wfs rfs -> Text
forall a b. (a -> b) -> a -> b
$ Table wfs rfs
tbl) Maybe Text
forall a. Maybe a
Nothing
   in (RequestHandler h ts
handler, SysOper'
sysOper)

list' ::
  forall i d f ids rfs r eff env es h ts. -- (record id) data (data filter) [id] (table read fields) (table record) eff effects (app env) arrow traits

  ( ids ~ [i],
    Integral i,
    DefaultFromField SqlInt8 i,
    Default FromFields rfs r,
    Reader env :> es,
    IOE :> es,
    eff ~ Eff es,
    StdHandler h eff,
    Gets h '[Body JSON (PageI f)],
    Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep (PageO [d])), Body JSON (Rep ())]
  ) =>
  SysOperTargetName ->
  (env -> Pool Connection) ->
  Select rfs ->
  (Maybe f -> rfs -> Field SqlBool) ->
  Order rfs ->
  (r -> d) ->
  (RequestHandler h ts, SysOper')
list' :: forall i d f ids rfs r (eff :: * -> *) env (es :: [Effect])
       (h :: * -> * -> *) (ts :: [*]).
(ids ~ [i], Integral i, DefaultFromField SqlInt8 i,
 Default FromFields rfs r, Reader env :> es, IOE :> es,
 eff ~ Eff es, StdHandler h eff, Gets h '[Body JSON (PageI f)],
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text,
     Body JSON (Rep (PageO [d])), Body JSON (Rep ())]) =>
Text
-> (env -> Pool Connection)
-> Select rfs
-> (Maybe f -> rfs -> Field SqlBool)
-> Order rfs
-> (r -> d)
-> (RequestHandler h ts, SysOper')
list' Text
tName env -> Pool Connection
envPool Select rfs
sel Maybe f -> rfs -> Field SqlBool
flt Order rfs
ord r -> d
r2d =
  let handler :: RequestHandler h ts
handler = forall t mt (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(Handler h m, Get h (Body mt t)) =>
mt
-> h (With Request ts, Text) Response
-> Middleware h ts (Body mt t : ts)
requestBody @(PageI f) JSON
JSON h (With Request ts, Text) Response
forall e (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(Show e, StdHandler h m,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text,
     Body JSON (Rep ())]) =>
h (With Request ts, e) Response
errorHandler Middleware h ts (Body JSON (PageI f) : ts)
-> Middleware h ts (Body JSON (PageI f) : ts)
forall a b. (a -> b) -> a -> b
$
        proc With Request (Body JSON (PageI f) : ts)
request -> do
          let pageI :: PageI f
pageI = forall {k} (t :: k) a. Tagged t a -> a
forall t a. Tagged t a -> a
pick @(Body JSON (PageI f)) (Tagged (Body JSON (PageI f)) (PageI f) -> PageI f)
-> Tagged (Body JSON (PageI f)) (PageI f) -> PageI f
forall a b. (a -> b) -> a -> b
$ With Request (Body JSON (PageI f) : ts)
-> Tagged
     (Body JSON (PageI f)) (Attribute (Body JSON (PageI f)) Request)
forall a.
With a (Body JSON (PageI f) : ts)
-> Tagged (Body JSON (PageI f)) (Attribute (Body JSON (PageI f)) a)
forall t (ts :: [*]) a.
HasTrait t ts =>
With a ts -> Tagged t (Attribute t a)
from With Request (Body JSON (PageI f) : ts)
request
          Rep (PageO [d])
res <-
            (PageI f -> Eff es (Rep (PageO [d])))
-> h (PageI f) (Rep (PageO [d]))
forall a b. (a -> Eff es b) -> h a b
forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM
              ( \PageI f
pageI -> Eff (Error Err : es) (Rep (PageO [d])) -> Eff es (Rep (PageO [d]))
forall (es :: [Effect]) a.
Eff (Error Err : es) (Rep a) -> Eff es (Rep a)
catchRep (Eff (Error Err : es) (Rep (PageO [d]))
 -> Eff es (Rep (PageO [d])))
-> Eff (Error Err : es) (Rep (PageO [d]))
-> Eff es (Rep (PageO [d]))
forall a b. (a -> b) -> a -> b
$ do
                  let mPage :: Maybe Page
mPage = PageI f -> Maybe Page
forall a. PageI a -> Maybe Page
_pageIPage PageI f
pageI
                  Pool Connection
pool <- (env -> Pool Connection) -> Eff (Error Err : es) (Pool Connection)
forall r (es :: [Effect]) a.
(HasCallStack, Reader r :> es) =>
(r -> a) -> Eff es a
asks env -> Pool Connection
envPool
                  ([r]
rs, [Natural]
cs) <- IO ([r], [Natural]) -> Eff (Error Err : es) ([r], [Natural])
forall a. IO a -> Eff (Error Err : es) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([r], [Natural]) -> Eff (Error Err : es) ([r], [Natural]))
-> ((Connection -> IO ([r], [Natural])) -> IO ([r], [Natural]))
-> (Connection -> IO ([r], [Natural]))
-> Eff (Error Err : es) ([r], [Natural])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool Connection
-> (Connection -> IO ([r], [Natural])) -> IO ([r], [Natural])
forall a r. Pool a -> (a -> IO r) -> IO r
withResource Pool Connection
pool ((Connection -> IO ([r], [Natural]))
 -> Eff (Error Err : es) ([r], [Natural]))
-> (Connection -> IO ([r], [Natural]))
-> Eff (Error Err : es) ([r], [Natural])
forall a b. (a -> b) -> a -> b
$
                    \Connection
conn -> do
                      let sel_ :: Select rfs
sel_ = do
                            rfs
r <- Select rfs
sel
                            Field SqlBool -> Select ()
where_ (Field SqlBool -> Select ()) -> Field SqlBool -> Select ()
forall a b. (a -> b) -> a -> b
$ Maybe f -> rfs -> Field SqlBool
flt (PageI f -> Maybe f
forall a. PageI a -> Maybe a
_pageIFilter PageI f
pageI) rfs
r
                            rfs -> Select rfs
forall a. a -> SelectArr () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure rfs
r
                      let sel' :: Select rfs
sel' = case Maybe Page
mPage of
                            Maybe Page
Nothing -> Select rfs
sel_
                            Just Page
page -> Int -> Select rfs -> Select rfs
forall a. Int -> Select a -> Select a
limit (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Int) -> Natural -> Int
forall a b. (a -> b) -> a -> b
$ Page
page Page -> Getting Natural Page Natural -> Natural
forall s a. s -> Getting a s a -> a
^. Getting Natural Page Natural
Lens' Page Natural
pageSize) (Select rfs -> Select rfs)
-> (Select rfs -> Select rfs) -> Select rfs -> Select rfs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Select rfs -> Select rfs
forall a. Int -> Select a -> Select a
offset (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Int) -> Natural -> Int
forall a b. (a -> b) -> a -> b
$ (Page
page Page -> Getting Natural Page Natural -> Natural
forall s a. s -> Getting a s a -> a
^. Getting Natural Page Natural
Lens' Page Natural
pageIndex Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1) Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* (Page
page Page -> Getting Natural Page Natural -> Natural
forall s a. s -> Getting a s a -> a
^. Getting Natural Page Natural
Lens' Page Natural
pageSize)) (Select rfs -> Select rfs)
-> (Select rfs -> Select rfs) -> Select rfs -> Select rfs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Order rfs -> Select rfs -> Select rfs
forall a. Order a -> Select a -> Select a
orderBy Order rfs
ord (Select rfs -> Select rfs) -> Select rfs -> Select rfs
forall a b. (a -> b) -> a -> b
$ Select rfs
sel_
                      [r]
rs <- Connection -> Select rfs -> IO [r]
forall fields haskells.
Default FromFields fields haskells =>
Connection -> Select fields -> IO [haskells]
runSelect Connection
conn Select rfs
sel'
                      [i]
cs <- Connection -> Select (Field SqlInt8) -> IO [i]
forall fields haskells.
Default FromFields fields haskells =>
Connection -> Select fields -> IO [haskells]
runSelect Connection
conn (Select (Field SqlInt8) -> IO [i])
-> (Select rfs -> Select (Field SqlInt8)) -> Select rfs -> IO [i]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Select rfs -> Select (Field SqlInt8)
forall a. Select a -> Select (Field SqlInt8)
countRows (Select rfs -> IO [i]) -> Select rfs -> IO [i]
forall a b. (a -> b) -> a -> b
$ Select rfs
sel
                      ([r], [Natural]) -> IO ([r], [Natural])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([r]
rs, i -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (i -> Natural) -> [i] -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ids
[i]
cs :: ids))
                  let count :: Natural
count = Natural -> Maybe Natural -> Natural
forall a. a -> Maybe a -> a
fromMaybe Natural
0 ([Natural] -> Maybe Natural
forall a. [a] -> Maybe a
listToMaybe [Natural]
cs)
                  let pageO :: [d] -> PageO [d]
pageO = case Maybe Page
mPage of
                        Maybe Page
Nothing -> Page -> Natural -> [d] -> PageO [d]
forall a. Page -> Natural -> a -> PageO a
PageO (Natural -> Natural -> Page
Page Natural
1 Natural
count) Natural
count
                        Just Page
page -> Page -> Natural -> [d] -> PageO [d]
forall a. Page -> Natural -> a -> PageO a
fillPage Page
page Natural
count
                  Rep (PageO [d]) -> Eff (Error Err : es) (Rep (PageO [d]))
forall a. a -> Eff (Error Err : es) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Rep (PageO [d]) -> Eff (Error Err : es) (Rep (PageO [d])))
-> ([d] -> Rep (PageO [d]))
-> [d]
-> Eff (Error Err : es) (Rep (PageO [d]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PageO [d] -> Rep (PageO [d])
forall a. a -> Rep a
rep (PageO [d] -> Rep (PageO [d]))
-> ([d] -> PageO [d]) -> [d] -> Rep (PageO [d])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [d] -> PageO [d]
pageO ([d] -> Eff (Error Err : es) (Rep (PageO [d])))
-> [d] -> Eff (Error Err : es) (Rep (PageO [d]))
forall a b. (a -> b) -> a -> b
$ r -> d
r2d (r -> d) -> [r] -> [d]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [r]
rs
              )
              -<
                PageI f
pageI
          Status -> JSON -> h (Rep (PageO [d])) Response
forall body mt (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
 Sets
   h
   '[Status, Body mt body,
     RequiredResponseHeader "Content-Type" Text],
 MIMEType mt) =>
Status -> mt -> h body Response
respondA Status
HTTP.ok200 JSON
JSON -< Rep (PageO [d])
res
      sysOper :: SysOper'
sysOper = Text -> Text -> Maybe Text -> SysOper'
SysOper' Text
"list" Text
tName Maybe Text
forall a. Maybe a
Nothing
   in (RequestHandler h ts
handler, SysOper'
sysOper)

get ::
  forall i fi d wfs rfs r eff env es h ts. -- (record id) (field id) data (table write fields) (table read fields) (table record) eff effects (app env) arrow traits

  ( Default Unpackspec rfs rfs,
    Default FromFields rfs r,
    Sel1 rfs (Field fi),
    Reader env :> es,
    IOE :> es,
    eff ~ Eff es,
    StdHandler h eff,
    HaveTraits '[PathVar "id" i] ts,
    Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep (Maybe d))]
  ) =>
  (env -> Pool Connection) ->
  Table wfs rfs ->
  (i -> Field fi) ->
  (r -> d) ->
  (RequestHandler h ts, SysOper')
get :: forall i fi d wfs rfs r (eff :: * -> *) env (es :: [Effect])
       (h :: * -> * -> *) (ts :: [*]).
(Default Unpackspec rfs rfs, Default FromFields rfs r,
 Sel1 rfs (Field fi), Reader env :> es, IOE :> es, eff ~ Eff es,
 StdHandler h eff, HaveTraits '[PathVar "id" i] ts,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text,
     Body JSON (Rep (Maybe d))]) =>
(env -> Pool Connection)
-> Table wfs rfs
-> (i -> Field fi)
-> (r -> d)
-> (RequestHandler h ts, SysOper')
get env -> Pool Connection
envPool Table wfs rfs
tbl i -> Field fi
idf r -> d
r2d =
  let handler :: h (With Request ts) Response
handler = proc With Request ts
request -> do
        let tid :: i
tid = forall {k} (t :: k) a. Tagged t a -> a
forall t a. Tagged t a -> a
pick @(PathVar "id" i) (Tagged (PathVar "id" i) i -> i) -> Tagged (PathVar "id" i) i -> i
forall a b. (a -> b) -> a -> b
$ With Request ts
-> Tagged (PathVar "id" i) (Attribute (PathVar "id" i) Request)
forall a.
With a ts -> Tagged (PathVar "id" i) (Attribute (PathVar "id" i) a)
forall t (ts :: [*]) a.
HasTrait t ts =>
With a ts -> Tagged t (Attribute t a)
from With Request ts
request
        (Maybe d
md :: Maybe d) <-
          (i -> Eff es (Maybe d)) -> h i (Maybe d)
forall a b. (a -> Eff es b) -> h a b
forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM
            ( \i
tid -> do
                Pool Connection
pool <- (env -> Pool Connection) -> Eff es (Pool Connection)
forall r (es :: [Effect]) a.
(HasCallStack, Reader r :> es) =>
(r -> a) -> Eff es a
asks env -> Pool Connection
envPool
                [r]
rs <- IO [r] -> Eff es [r]
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [r] -> Eff es [r])
-> ((Connection -> IO [r]) -> IO [r])
-> (Connection -> IO [r])
-> Eff es [r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool Connection -> (Connection -> IO [r]) -> IO [r]
forall a r. Pool a -> (a -> IO r) -> IO r
withResource Pool Connection
pool ((Connection -> IO [r]) -> Eff es [r])
-> (Connection -> IO [r]) -> Eff es [r]
forall a b. (a -> b) -> a -> b
$
                  \Connection
conn -> Connection -> Select rfs -> IO [r]
forall fields haskells.
Default FromFields fields haskells =>
Connection -> Select fields -> IO [haskells]
runSelect Connection
conn (Select rfs -> IO [r]) -> Select rfs -> IO [r]
forall a b. (a -> b) -> a -> b
$ do
                    rfs
r <- Table wfs rfs -> Select rfs
forall fields a.
Default Unpackspec fields fields =>
Table a fields -> Select fields
selectTable Table wfs rfs
tbl
                    Field SqlBool -> Select ()
where_ (Field SqlBool -> Select ()) -> Field SqlBool -> Select ()
forall a b. (a -> b) -> a -> b
$ rfs -> Field fi
forall a b. Sel1 a b => a -> b
sel1 rfs
r Field fi -> Field fi -> Field SqlBool
forall a. Field a -> Field a -> Field SqlBool
.== i -> Field fi
idf i
tid
                    rfs -> Select rfs
forall a. a -> SelectArr () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure rfs
r
                Maybe d -> Eff es (Maybe d)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe d -> Eff es (Maybe d))
-> ([d] -> Maybe d) -> [d] -> Eff es (Maybe d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [d] -> Maybe d
forall a. [a] -> Maybe a
listToMaybe ([d] -> Eff es (Maybe d)) -> [d] -> Eff es (Maybe d)
forall a b. (a -> b) -> a -> b
$ r -> d
r2d (r -> d) -> [r] -> [d]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [r]
rs
            )
            -<
              i
tid
        Status -> JSON -> h (Rep (Maybe d)) Response
forall body mt (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
 Sets
   h
   '[Status, Body mt body,
     RequiredResponseHeader "Content-Type" Text],
 MIMEType mt) =>
Status -> mt -> h body Response
respondA Status
HTTP.ok200 JSON
JSON -< Maybe d -> Rep (Maybe d)
forall a. a -> Rep a
rep Maybe d
md
      sysOper :: SysOper'
sysOper = Text -> Text -> Maybe Text -> SysOper'
SysOper' Text
"get" (String -> Text
pack (String -> Text)
-> (Table wfs rfs -> String) -> Table wfs rfs -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableIdentifier -> String
forall a. Show a => a -> String
show (TableIdentifier -> String)
-> (Table wfs rfs -> TableIdentifier) -> Table wfs rfs -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table wfs rfs -> TableIdentifier
forall writeColumns viewColumns.
Table writeColumns viewColumns -> TableIdentifier
tableIdentifier (Table wfs rfs -> Text) -> Table wfs rfs -> Text
forall a b. (a -> b) -> a -> b
$ Table wfs rfs
tbl) Maybe Text
forall a. Maybe a
Nothing
   in (h (With Request ts) Response
handler, SysOper'
sysOper)

get' ::
  forall i d eff env es h ts. -- (record id) data eff effects (app env) arrow traits

  ( Reader env :> es,
    IOE :> es,
    eff ~ Eff es,
    StdHandler h eff,
    HaveTraits '[PathVar "id" i] ts,
    Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep (Maybe d))]
  ) =>
  SysOperTargetName ->
  (env -> Pool Connection) ->
  (Connection -> i -> IO (Maybe d)) ->
  (RequestHandler h ts, SysOper')
get' :: forall i d (eff :: * -> *) env (es :: [Effect]) (h :: * -> * -> *)
       (ts :: [*]).
(Reader env :> es, IOE :> es, eff ~ Eff es, StdHandler h eff,
 HaveTraits '[PathVar "id" i] ts,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text,
     Body JSON (Rep (Maybe d))]) =>
Text
-> (env -> Pool Connection)
-> (Connection -> i -> IO (Maybe d))
-> (RequestHandler h ts, SysOper')
get' Text
tName env -> Pool Connection
envPool Connection -> i -> IO (Maybe d)
sel =
  let handler :: h (With Request ts) Response
handler = proc With Request ts
request -> do
        let tid :: i
tid = forall {k} (t :: k) a. Tagged t a -> a
forall t a. Tagged t a -> a
pick @(PathVar "id" i) (Tagged (PathVar "id" i) i -> i) -> Tagged (PathVar "id" i) i -> i
forall a b. (a -> b) -> a -> b
$ With Request ts
-> Tagged (PathVar "id" i) (Attribute (PathVar "id" i) Request)
forall a.
With a ts -> Tagged (PathVar "id" i) (Attribute (PathVar "id" i) a)
forall t (ts :: [*]) a.
HasTrait t ts =>
With a ts -> Tagged t (Attribute t a)
from With Request ts
request
        (Maybe d
md :: Maybe d) <-
          (i -> Eff es (Maybe d)) -> h i (Maybe d)
forall a b. (a -> Eff es b) -> h a b
forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM
            ( \i
tid -> do
                Pool Connection
pool <- (env -> Pool Connection) -> Eff es (Pool Connection)
forall r (es :: [Effect]) a.
(HasCallStack, Reader r :> es) =>
(r -> a) -> Eff es a
asks env -> Pool Connection
envPool
                IO (Maybe d) -> Eff es (Maybe d)
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe d) -> Eff es (Maybe d))
-> ((Connection -> IO (Maybe d)) -> IO (Maybe d))
-> (Connection -> IO (Maybe d))
-> Eff es (Maybe d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool Connection -> (Connection -> IO (Maybe d)) -> IO (Maybe d)
forall a r. Pool a -> (a -> IO r) -> IO r
withResource Pool Connection
pool ((Connection -> IO (Maybe d)) -> Eff es (Maybe d))
-> (Connection -> IO (Maybe d)) -> Eff es (Maybe d)
forall a b. (a -> b) -> a -> b
$
                  \Connection
conn -> Connection -> i -> IO (Maybe d)
sel Connection
conn i
tid
            )
            -<
              i
tid
        Status -> JSON -> h (Rep (Maybe d)) Response
forall body mt (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
 Sets
   h
   '[Status, Body mt body,
     RequiredResponseHeader "Content-Type" Text],
 MIMEType mt) =>
Status -> mt -> h body Response
respondA Status
HTTP.ok200 JSON
JSON -< Maybe d -> Rep (Maybe d)
forall a. a -> Rep a
rep Maybe d
md
      sysOper :: SysOper'
sysOper = Text -> Text -> Maybe Text -> SysOper'
SysOper' Text
"get" Text
tName Maybe Text
forall a. Maybe a
Nothing
   in (h (With Request ts) Response
handler, SysOper'
sysOper)

add ::
  forall i fi a wfs rfs eff env es h ts. -- (record id) (field id) (data to add) (table write fields) (table read fields) eff effects (app env) arrow traits

  ( Sel1 rfs (Field fi),
    DefaultFromField fi i,
    Reader env :> es,
    IOE :> es,
    eff ~ Eff es,
    StdHandler h eff,
    Gets h '[Body JSON a],
    Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep i), Body JSON (Rep ())]
  ) =>
  (env -> Pool Connection) ->
  Table wfs rfs ->
  (a -> [wfs]) ->
  (RequestHandler h ts, SysOper')
add :: forall i fi a wfs rfs (eff :: * -> *) env (es :: [Effect])
       (h :: * -> * -> *) (ts :: [*]).
(Sel1 rfs (Field fi), DefaultFromField fi i, Reader env :> es,
 IOE :> es, eff ~ Eff es, StdHandler h eff, Gets h '[Body JSON a],
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep i),
     Body JSON (Rep ())]) =>
(env -> Pool Connection)
-> Table wfs rfs -> (a -> [wfs]) -> (RequestHandler h ts, SysOper')
add env -> Pool Connection
envPool Table wfs rfs
tbl a -> [wfs]
a2t =
  let handler :: RequestHandler h ts
handler = forall t mt (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(Handler h m, Get h (Body mt t)) =>
mt
-> h (With Request ts, Text) Response
-> Middleware h ts (Body mt t : ts)
requestBody @a JSON
JSON h (With Request ts, Text) Response
forall e (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(Show e, StdHandler h m,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text,
     Body JSON (Rep ())]) =>
h (With Request ts, e) Response
errorHandler Middleware h ts (Body JSON a : ts)
-> Middleware h ts (Body JSON a : ts)
forall a b. (a -> b) -> a -> b
$
        proc With Request (Body JSON a : ts)
request -> do
          let toAdd :: a
toAdd = forall {k} (t :: k) a. Tagged t a -> a
forall t a. Tagged t a -> a
pick @(Body JSON a) (Tagged (Body JSON a) a -> a) -> Tagged (Body JSON a) a -> a
forall a b. (a -> b) -> a -> b
$ With Request (Body JSON a : ts)
-> Tagged (Body JSON a) (Attribute (Body JSON a) Request)
forall a.
With a (Body JSON a : ts)
-> Tagged (Body JSON a) (Attribute (Body JSON a) a)
forall t (ts :: [*]) a.
HasTrait t ts =>
With a ts -> Tagged t (Attribute t a)
from With Request (Body JSON a : ts)
request
          Rep i
rep_ <-
            (a -> Eff es (Rep i)) -> h a (Rep i)
forall a b. (a -> Eff es b) -> h a b
forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM
              ( \a
toAdd -> Eff (Error Err : es) (Rep i) -> Eff es (Rep i)
forall (es :: [Effect]) a.
Eff (Error Err : es) (Rep a) -> Eff es (Rep a)
catchRep (Eff (Error Err : es) (Rep i) -> Eff es (Rep i))
-> Eff (Error Err : es) (Rep i) -> Eff es (Rep i)
forall a b. (a -> b) -> a -> b
$ do
                  Pool Connection
pool <- (env -> Pool Connection) -> Eff (Error Err : es) (Pool Connection)
forall r (es :: [Effect]) a.
(HasCallStack, Reader r :> es) =>
(r -> a) -> Eff es a
asks env -> Pool Connection
envPool
                  [i]
ids <- IO [i] -> Eff (Error Err : es) [i]
forall a. IO a -> Eff (Error Err : es) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [i] -> Eff (Error Err : es) [i])
-> ((Connection -> IO [i]) -> IO [i])
-> (Connection -> IO [i])
-> Eff (Error Err : es) [i]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool Connection -> (Connection -> IO [i]) -> IO [i]
forall a r. Pool a -> (a -> IO r) -> IO r
withResource Pool Connection
pool ((Connection -> IO [i]) -> Eff (Error Err : es) [i])
-> (Connection -> IO [i]) -> Eff (Error Err : es) [i]
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
                    Connection -> Insert [i] -> IO [i]
forall haskells. Connection -> Insert haskells -> IO haskells
runInsert
                      Connection
conn
                      Insert
                        { iTable :: Table wfs rfs
iTable = Table wfs rfs
tbl,
                          iRows :: [wfs]
iRows = a -> [wfs]
a2t a
toAdd,
                          iReturning :: Returning rfs [i]
iReturning = (rfs -> Field fi) -> Returning rfs [i]
forall fields haskells fieldsR.
Default FromFields fields haskells =>
(fieldsR -> fields) -> Returning fieldsR [haskells]
rReturning rfs -> Field fi
forall a b. Sel1 a b => a -> b
sel1,
                          iOnConflict :: Maybe OnConflict
iOnConflict = Maybe OnConflict
forall a. Maybe a
Nothing
                        }
                  Eff (Error Err : es) (Rep i)
-> (i -> Eff (Error Err : es) (Rep i))
-> Maybe i
-> Eff (Error Err : es) (Rep i)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Err -> Eff (Error Err : es) (Rep i)
forall e (es :: [Effect]) a.
(HasCallStack, Error e :> es) =>
e -> Eff es a
throwError (Err -> Eff (Error Err : es) (Rep i))
-> Err -> Eff (Error Err : es) (Rep i)
forall a b. (a -> b) -> a -> b
$ Natural -> Text -> Err
Err Natural
1 Text
"insert failure") (Rep i -> Eff (Error Err : es) (Rep i)
forall a. a -> Eff (Error Err : es) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Rep i -> Eff (Error Err : es) (Rep i))
-> (i -> Rep i) -> i -> Eff (Error Err : es) (Rep i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> Rep i
forall a. a -> Rep a
rep) ([i] -> Maybe i
forall a. [a] -> Maybe a
listToMaybe [i]
ids)
              )
              -<
                a
toAdd
          Status -> JSON -> h (Rep i) Response
forall body mt (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
 Sets
   h
   '[Status, Body mt body,
     RequiredResponseHeader "Content-Type" Text],
 MIMEType mt) =>
Status -> mt -> h body Response
respondA Status
HTTP.ok200 JSON
JSON -< (Rep i
rep_ :: Rep i)
      sysOper :: SysOper'
sysOper = Text -> Text -> Maybe Text -> SysOper'
SysOper' Text
"add" (String -> Text
pack (String -> Text)
-> (Table wfs rfs -> String) -> Table wfs rfs -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableIdentifier -> String
forall a. Show a => a -> String
show (TableIdentifier -> String)
-> (Table wfs rfs -> TableIdentifier) -> Table wfs rfs -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table wfs rfs -> TableIdentifier
forall writeColumns viewColumns.
Table writeColumns viewColumns -> TableIdentifier
tableIdentifier (Table wfs rfs -> Text) -> Table wfs rfs -> Text
forall a b. (a -> b) -> a -> b
$ Table wfs rfs
tbl) Maybe Text
forall a. Maybe a
Nothing
   in (RequestHandler h ts
handler, SysOper'
sysOper)

add' ::
  forall i a eff env es h ts. -- (record id) (data to add) eff effects (app env) arrow traits

  ( Reader env :> es,
    IOE :> es,
    eff ~ Eff es,
    StdHandler h eff,
    Gets h '[Body JSON a],
    Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep i), Body JSON (Rep ())]
  ) =>
  SysOperTargetName ->
  (env -> Pool Connection) ->
  (Connection -> a -> IO i) ->
  (RequestHandler h ts, SysOper')
add' :: forall i a (eff :: * -> *) env (es :: [Effect]) (h :: * -> * -> *)
       (ts :: [*]).
(Reader env :> es, IOE :> es, eff ~ Eff es, StdHandler h eff,
 Gets h '[Body JSON a],
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep i),
     Body JSON (Rep ())]) =>
Text
-> (env -> Pool Connection)
-> (Connection -> a -> IO i)
-> (RequestHandler h ts, SysOper')
add' Text
tName env -> Pool Connection
envPool Connection -> a -> IO i
oper =
  let handler :: RequestHandler h ts
handler = forall t mt (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(Handler h m, Get h (Body mt t)) =>
mt
-> h (With Request ts, Text) Response
-> Middleware h ts (Body mt t : ts)
requestBody @a JSON
JSON h (With Request ts, Text) Response
forall e (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(Show e, StdHandler h m,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text,
     Body JSON (Rep ())]) =>
h (With Request ts, e) Response
errorHandler Middleware h ts (Body JSON a : ts)
-> Middleware h ts (Body JSON a : ts)
forall a b. (a -> b) -> a -> b
$
        proc With Request (Body JSON a : ts)
request -> do
          let toAdd :: a
toAdd = forall {k} (t :: k) a. Tagged t a -> a
forall t a. Tagged t a -> a
pick @(Body JSON a) (Tagged (Body JSON a) a -> a) -> Tagged (Body JSON a) a -> a
forall a b. (a -> b) -> a -> b
$ With Request (Body JSON a : ts)
-> Tagged (Body JSON a) (Attribute (Body JSON a) Request)
forall a.
With a (Body JSON a : ts)
-> Tagged (Body JSON a) (Attribute (Body JSON a) a)
forall t (ts :: [*]) a.
HasTrait t ts =>
With a ts -> Tagged t (Attribute t a)
from With Request (Body JSON a : ts)
request
          Rep i
rep_ <-
            (a -> Eff es (Rep i)) -> h a (Rep i)
forall a b. (a -> Eff es b) -> h a b
forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM
              ( \a
toAdd -> Eff (Error Err : es) (Rep i) -> Eff es (Rep i)
forall (es :: [Effect]) a.
Eff (Error Err : es) (Rep a) -> Eff es (Rep a)
catchRep (Eff (Error Err : es) (Rep i) -> Eff es (Rep i))
-> Eff (Error Err : es) (Rep i) -> Eff es (Rep i)
forall a b. (a -> b) -> a -> b
$ do
                  Pool Connection
pool <- (env -> Pool Connection) -> Eff (Error Err : es) (Pool Connection)
forall r (es :: [Effect]) a.
(HasCallStack, Reader r :> es) =>
(r -> a) -> Eff es a
asks env -> Pool Connection
envPool
                  IO (Rep i) -> Eff (Error Err : es) (Rep i)
forall a. IO a -> Eff (Error Err : es) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Rep i) -> Eff (Error Err : es) (Rep i))
-> ((Connection -> IO (Rep i)) -> IO (Rep i))
-> (Connection -> IO (Rep i))
-> Eff (Error Err : es) (Rep i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool Connection -> (Connection -> IO (Rep i)) -> IO (Rep i)
forall a r. Pool a -> (a -> IO r) -> IO r
withResource Pool Connection
pool ((Connection -> IO (Rep i)) -> Eff (Error Err : es) (Rep i))
-> (Connection -> IO (Rep i)) -> Eff (Error Err : es) (Rep i)
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> i -> Rep i
forall a. a -> Rep a
rep (i -> Rep i) -> IO i -> IO (Rep i)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> a -> IO i
oper Connection
conn a
toAdd
              )
              -<
                a
toAdd
          Status -> JSON -> h (Rep i) Response
forall body mt (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
 Sets
   h
   '[Status, Body mt body,
     RequiredResponseHeader "Content-Type" Text],
 MIMEType mt) =>
Status -> mt -> h body Response
respondA Status
HTTP.ok200 JSON
JSON -< Rep i
rep_
      sysOper :: SysOper'
sysOper = Text -> Text -> Maybe Text -> SysOper'
SysOper' Text
"add" Text
tName Maybe Text
forall a. Maybe a
Nothing
   in (RequestHandler h ts
handler, SysOper'
sysOper)

dup ::
  forall i fi wfs rfs r eff env es h ts. -- (record id) (field id) (table write fields) (table read fields) (table record) eff effects (app env) arrow traits

  ( Default Unpackspec rfs rfs,
    Default FromFields rfs r,
    Sel1 rfs (Field fi),
    DefaultFromField fi i,
    Reader env :> es,
    IOE :> es,
    eff ~ Eff es,
    StdHandler h eff,
    HaveTraits '[PathVar "id" i] ts,
    Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep i), Body JSON (Rep ())]
  ) =>
  (env -> Pool Connection) ->
  Table wfs rfs ->
  (i -> Field fi) ->
  (r -> wfs) ->
  (RequestHandler h ts, SysOper')
dup :: forall i fi wfs rfs r (eff :: * -> *) env (es :: [Effect])
       (h :: * -> * -> *) (ts :: [*]).
(Default Unpackspec rfs rfs, Default FromFields rfs r,
 Sel1 rfs (Field fi), DefaultFromField fi i, Reader env :> es,
 IOE :> es, eff ~ Eff es, StdHandler h eff,
 HaveTraits '[PathVar "id" i] ts,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep i),
     Body JSON (Rep ())]) =>
(env -> Pool Connection)
-> Table wfs rfs
-> (i -> Field fi)
-> (r -> wfs)
-> (RequestHandler h ts, SysOper')
dup env -> Pool Connection
envPool Table wfs rfs
tbl i -> Field fi
idf r -> wfs
r2t =
  let handler :: h (With Request ts) Response
handler = proc With Request ts
request -> do
        let tid :: i
tid = forall {k} (t :: k) a. Tagged t a -> a
forall t a. Tagged t a -> a
pick @(PathVar "id" i) (Tagged (PathVar "id" i) i -> i) -> Tagged (PathVar "id" i) i -> i
forall a b. (a -> b) -> a -> b
$ With Request ts
-> Tagged (PathVar "id" i) (Attribute (PathVar "id" i) Request)
forall a.
With a ts -> Tagged (PathVar "id" i) (Attribute (PathVar "id" i) a)
forall t (ts :: [*]) a.
HasTrait t ts =>
With a ts -> Tagged t (Attribute t a)
from With Request ts
request
        Rep i
tid_ <-
          (i -> Eff es (Rep i)) -> h i (Rep i)
forall a b. (a -> Eff es b) -> h a b
forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM
            ( \i
tid -> Eff (Error Err : es) (Rep i) -> Eff es (Rep i)
forall (es :: [Effect]) a.
Eff (Error Err : es) (Rep a) -> Eff es (Rep a)
catchRep (Eff (Error Err : es) (Rep i) -> Eff es (Rep i))
-> Eff (Error Err : es) (Rep i) -> Eff es (Rep i)
forall a b. (a -> b) -> a -> b
$ do
                Pool Connection
pool <- (env -> Pool Connection) -> Eff (Error Err : es) (Pool Connection)
forall r (es :: [Effect]) a.
(HasCallStack, Reader r :> es) =>
(r -> a) -> Eff es a
asks env -> Pool Connection
envPool
                [i]
ids <- IO [i] -> Eff (Error Err : es) [i]
forall a. IO a -> Eff (Error Err : es) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [i] -> Eff (Error Err : es) [i])
-> ((Connection -> IO [i]) -> IO [i])
-> (Connection -> IO [i])
-> Eff (Error Err : es) [i]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool Connection -> (Connection -> IO [i]) -> IO [i]
forall a r. Pool a -> (a -> IO r) -> IO r
withResource Pool Connection
pool ((Connection -> IO [i]) -> Eff (Error Err : es) [i])
-> (Connection -> IO [i]) -> Eff (Error Err : es) [i]
forall a b. (a -> b) -> a -> b
$
                  \Connection
conn -> do
                    [r]
rs <- Connection -> Select rfs -> IO [r]
forall fields haskells.
Default FromFields fields haskells =>
Connection -> Select fields -> IO [haskells]
runSelect Connection
conn (Select rfs -> IO [r]) -> Select rfs -> IO [r]
forall a b. (a -> b) -> a -> b
$ do
                      rfs
r <- Table wfs rfs -> Select rfs
forall fields a.
Default Unpackspec fields fields =>
Table a fields -> Select fields
selectTable Table wfs rfs
tbl
                      Field SqlBool -> Select ()
where_ (Field SqlBool -> Select ()) -> Field SqlBool -> Select ()
forall a b. (a -> b) -> a -> b
$ rfs -> Field fi
forall a b. Sel1 a b => a -> b
sel1 rfs
r Field fi -> Field fi -> Field SqlBool
forall a. Field a -> Field a -> Field SqlBool
.== i -> Field fi
idf i
tid
                      rfs -> Select rfs
forall a. a -> SelectArr () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure rfs
r
                    Connection -> Insert [i] -> IO [i]
forall haskells. Connection -> Insert haskells -> IO haskells
runInsert
                      Connection
conn
                      Insert
                        { iTable :: Table wfs rfs
iTable = Table wfs rfs
tbl,
                          iRows :: [wfs]
iRows = r -> wfs
r2t (r -> wfs) -> [r] -> [wfs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [r]
rs,
                          iReturning :: Returning rfs [i]
iReturning = (rfs -> Field fi) -> Returning rfs [i]
forall fields haskells fieldsR.
Default FromFields fields haskells =>
(fieldsR -> fields) -> Returning fieldsR [haskells]
rReturning rfs -> Field fi
forall a b. Sel1 a b => a -> b
sel1,
                          iOnConflict :: Maybe OnConflict
iOnConflict = Maybe OnConflict
forall a. Maybe a
Nothing
                        }
                Eff (Error Err : es) (Rep i)
-> (i -> Eff (Error Err : es) (Rep i))
-> Maybe i
-> Eff (Error Err : es) (Rep i)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Err -> Eff (Error Err : es) (Rep i)
forall e (es :: [Effect]) a.
(HasCallStack, Error e :> es) =>
e -> Eff es a
throwError (Err -> Eff (Error Err : es) (Rep i))
-> Err -> Eff (Error Err : es) (Rep i)
forall a b. (a -> b) -> a -> b
$ Natural -> Text -> Err
Err Natural
1 Text
"duplicate failure") (Rep i -> Eff (Error Err : es) (Rep i)
forall a. a -> Eff (Error Err : es) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Rep i -> Eff (Error Err : es) (Rep i))
-> (i -> Rep i) -> i -> Eff (Error Err : es) (Rep i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> Rep i
forall a. a -> Rep a
rep) ([i] -> Maybe i
forall a. [a] -> Maybe a
listToMaybe [i]
ids)
            )
            -<
              i
tid
        Status -> JSON -> h (Rep i) Response
forall body mt (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
 Sets
   h
   '[Status, Body mt body,
     RequiredResponseHeader "Content-Type" Text],
 MIMEType mt) =>
Status -> mt -> h body Response
respondA Status
HTTP.ok200 JSON
JSON -< (Rep i
tid_ :: Rep i)
      sysOper :: SysOper'
sysOper = Text -> Text -> Maybe Text -> SysOper'
SysOper' Text
"dup" (String -> Text
pack (String -> Text)
-> (Table wfs rfs -> String) -> Table wfs rfs -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableIdentifier -> String
forall a. Show a => a -> String
show (TableIdentifier -> String)
-> (Table wfs rfs -> TableIdentifier) -> Table wfs rfs -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table wfs rfs -> TableIdentifier
forall writeColumns viewColumns.
Table writeColumns viewColumns -> TableIdentifier
tableIdentifier (Table wfs rfs -> Text) -> Table wfs rfs -> Text
forall a b. (a -> b) -> a -> b
$ Table wfs rfs
tbl) Maybe Text
forall a. Maybe a
Nothing
   in (h (With Request ts) Response
handler, SysOper'
sysOper)

dup' ::
  forall i eff env es h ts. -- (record id) eff effects (app env) arrow traits

  ( Reader env :> es,
    IOE :> es,
    eff ~ Eff es,
    StdHandler h eff,
    HaveTraits '[PathVar "id" i] ts,
    Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep i), Body JSON (Rep ())]
  ) =>
  SysOperTargetName ->
  (env -> Pool Connection) ->
  (Connection -> i -> IO i) ->
  (RequestHandler h ts, SysOper')
dup' :: forall i (eff :: * -> *) env (es :: [Effect]) (h :: * -> * -> *)
       (ts :: [*]).
(Reader env :> es, IOE :> es, eff ~ Eff es, StdHandler h eff,
 HaveTraits '[PathVar "id" i] ts,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep i),
     Body JSON (Rep ())]) =>
Text
-> (env -> Pool Connection)
-> (Connection -> i -> IO i)
-> (RequestHandler h ts, SysOper')
dup' Text
tName env -> Pool Connection
envPool Connection -> i -> IO i
oper =
  let handler :: h (With Request ts) Response
handler = proc With Request ts
request -> do
        let tid :: i
tid = forall {k} (t :: k) a. Tagged t a -> a
forall t a. Tagged t a -> a
pick @(PathVar "id" i) (Tagged (PathVar "id" i) i -> i) -> Tagged (PathVar "id" i) i -> i
forall a b. (a -> b) -> a -> b
$ With Request ts
-> Tagged (PathVar "id" i) (Attribute (PathVar "id" i) Request)
forall a.
With a ts -> Tagged (PathVar "id" i) (Attribute (PathVar "id" i) a)
forall t (ts :: [*]) a.
HasTrait t ts =>
With a ts -> Tagged t (Attribute t a)
from With Request ts
request
        Rep i
rep_ <-
          ((i, Connection -> i -> IO i) -> Eff es (Rep i))
-> h (i, Connection -> i -> IO i) (Rep i)
forall a b. (a -> Eff es b) -> h a b
forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM
            ( \(i
tid, Connection -> i -> IO i
oper_) -> Eff (Error Err : es) (Rep i) -> Eff es (Rep i)
forall (es :: [Effect]) a.
Eff (Error Err : es) (Rep a) -> Eff es (Rep a)
catchRep (Eff (Error Err : es) (Rep i) -> Eff es (Rep i))
-> Eff (Error Err : es) (Rep i) -> Eff es (Rep i)
forall a b. (a -> b) -> a -> b
$ do
                Pool Connection
pool <- (env -> Pool Connection) -> Eff (Error Err : es) (Pool Connection)
forall r (es :: [Effect]) a.
(HasCallStack, Reader r :> es) =>
(r -> a) -> Eff es a
asks env -> Pool Connection
envPool
                IO (Rep i) -> Eff (Error Err : es) (Rep i)
forall a. IO a -> Eff (Error Err : es) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Rep i) -> Eff (Error Err : es) (Rep i))
-> ((Connection -> IO (Rep i)) -> IO (Rep i))
-> (Connection -> IO (Rep i))
-> Eff (Error Err : es) (Rep i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool Connection -> (Connection -> IO (Rep i)) -> IO (Rep i)
forall a r. Pool a -> (a -> IO r) -> IO r
withResource Pool Connection
pool ((Connection -> IO (Rep i)) -> Eff (Error Err : es) (Rep i))
-> (Connection -> IO (Rep i)) -> Eff (Error Err : es) (Rep i)
forall a b. (a -> b) -> a -> b
$
                  \Connection
conn -> i -> Rep i
forall a. a -> Rep a
rep (i -> Rep i) -> IO i -> IO (Rep i)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> i -> IO i
oper_ Connection
conn i
tid
            )
            -<
              (i
tid, Connection -> i -> IO i
oper)
        Status -> JSON -> h (Rep i) Response
forall body mt (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
 Sets
   h
   '[Status, Body mt body,
     RequiredResponseHeader "Content-Type" Text],
 MIMEType mt) =>
Status -> mt -> h body Response
respondA Status
HTTP.ok200 JSON
JSON -< Rep i
rep_
      sysOper :: SysOper'
sysOper = Text -> Text -> Maybe Text -> SysOper'
SysOper' Text
"dup" Text
tName Maybe Text
forall a. Maybe a
Nothing
   in (h (With Request ts) Response
handler, SysOper'
sysOper)

upd ::
  forall i fi u wfs rfs d r eff env es h ts. -- (record id) (field id) update (table write fields) (table read fields) data (table record) eff effects (app env) arrow traits

  ( Sel1 rfs (Field fi),
    Default FromFields rfs r,
    Reader env :> es,
    IOE :> es,
    eff ~ Eff es,
    StdHandler h eff,
    HaveTraits '[PathVar "id" i] ts,
    Gets h '[Body JSON u],
    Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep d), Body JSON (Rep ())]
  ) =>
  (env -> Pool Connection) ->
  Table wfs rfs ->
  (i -> Field fi) ->
  (u -> (rfs -> wfs)) ->
  (r -> d) ->
  (RequestHandler h ts, SysOper')
upd :: forall i fi u wfs rfs d r (eff :: * -> *) env (es :: [Effect])
       (h :: * -> * -> *) (ts :: [*]).
(Sel1 rfs (Field fi), Default FromFields rfs r, Reader env :> es,
 IOE :> es, eff ~ Eff es, StdHandler h eff,
 HaveTraits '[PathVar "id" i] ts, Gets h '[Body JSON u],
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep d),
     Body JSON (Rep ())]) =>
(env -> Pool Connection)
-> Table wfs rfs
-> (i -> Field fi)
-> (u -> rfs -> wfs)
-> (r -> d)
-> (RequestHandler h ts, SysOper')
upd env -> Pool Connection
envPool Table wfs rfs
tbl i -> Field fi
idf u -> rfs -> wfs
u2t r -> d
r2d =
  let handler :: RequestHandler h ts
handler = forall t mt (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(Handler h m, Get h (Body mt t)) =>
mt
-> h (With Request ts, Text) Response
-> Middleware h ts (Body mt t : ts)
requestBody @u JSON
JSON h (With Request ts, Text) Response
forall e (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(Show e, StdHandler h m,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text,
     Body JSON (Rep ())]) =>
h (With Request ts, e) Response
errorHandler Middleware h ts (Body JSON u : ts)
-> Middleware h ts (Body JSON u : ts)
forall a b. (a -> b) -> a -> b
$
        proc With Request (Body JSON u : ts)
request -> do
          let tid :: i
tid = forall {k} (t :: k) a. Tagged t a -> a
forall t a. Tagged t a -> a
pick @(PathVar "id" i) (Tagged (PathVar "id" i) i -> i) -> Tagged (PathVar "id" i) i -> i
forall a b. (a -> b) -> a -> b
$ With Request (Body JSON u : ts)
-> Tagged (PathVar "id" i) (Attribute (PathVar "id" i) Request)
forall a.
With a (Body JSON u : ts)
-> Tagged (PathVar "id" i) (Attribute (PathVar "id" i) a)
forall t (ts :: [*]) a.
HasTrait t ts =>
With a ts -> Tagged t (Attribute t a)
from With Request (Body JSON u : ts)
request
          let toUpd :: u
toUpd = forall {k} (t :: k) a. Tagged t a -> a
forall t a. Tagged t a -> a
pick @(Body JSON u) (Tagged (Body JSON u) u -> u) -> Tagged (Body JSON u) u -> u
forall a b. (a -> b) -> a -> b
$ With Request (Body JSON u : ts)
-> Tagged (Body JSON u) (Attribute (Body JSON u) Request)
forall a.
With a (Body JSON u : ts)
-> Tagged (Body JSON u) (Attribute (Body JSON u) a)
forall t (ts :: [*]) a.
HasTrait t ts =>
With a ts -> Tagged t (Attribute t a)
from With Request (Body JSON u : ts)
request
          Rep d
ru <-
            ((i, u) -> Eff es (Rep d)) -> h (i, u) (Rep d)
forall a b. (a -> Eff es b) -> h a b
forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM
              ( \(i
tid, u
toUpd) -> Eff (Error Err : es) (Rep d) -> Eff es (Rep d)
forall (es :: [Effect]) a.
Eff (Error Err : es) (Rep a) -> Eff es (Rep a)
catchRep (Eff (Error Err : es) (Rep d) -> Eff es (Rep d))
-> Eff (Error Err : es) (Rep d) -> Eff es (Rep d)
forall a b. (a -> b) -> a -> b
$ do
                  Pool Connection
pool <- (env -> Pool Connection) -> Eff (Error Err : es) (Pool Connection)
forall r (es :: [Effect]) a.
(HasCallStack, Reader r :> es) =>
(r -> a) -> Eff es a
asks env -> Pool Connection
envPool
                  [r]
ru <- IO [r] -> Eff (Error Err : es) [r]
forall a. IO a -> Eff (Error Err : es) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [r] -> Eff (Error Err : es) [r])
-> ((Connection -> IO [r]) -> IO [r])
-> (Connection -> IO [r])
-> Eff (Error Err : es) [r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool Connection -> (Connection -> IO [r]) -> IO [r]
forall a r. Pool a -> (a -> IO r) -> IO r
withResource Pool Connection
pool ((Connection -> IO [r]) -> Eff (Error Err : es) [r])
-> (Connection -> IO [r]) -> Eff (Error Err : es) [r]
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
                    Connection -> Update [r] -> IO [r]
forall haskells. Connection -> Update haskells -> IO haskells
runUpdate
                      Connection
conn
                      Update
                        { uTable :: Table wfs rfs
uTable = Table wfs rfs
tbl,
                          uUpdateWith :: rfs -> wfs
uUpdateWith = u -> rfs -> wfs
u2t u
toUpd,
                          uWhere :: rfs -> Field SqlBool
uWhere = (Field fi -> Field fi -> Field SqlBool
forall a. Field a -> Field a -> Field SqlBool
.== i -> Field fi
idf i
tid) (Field fi -> Field SqlBool)
-> (rfs -> Field fi) -> rfs -> Field SqlBool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. rfs -> Field fi
forall a b. Sel1 a b => a -> b
sel1,
                          uReturning :: Returning rfs [r]
uReturning = (rfs -> rfs) -> Returning rfs [r]
forall fields haskells fieldsR.
Default FromFields fields haskells =>
(fieldsR -> fields) -> Returning fieldsR [haskells]
rReturning rfs -> rfs
forall a. a -> a
id
                        }
                  Eff (Error Err : es) (Rep d)
-> (r -> Eff (Error Err : es) (Rep d))
-> Maybe r
-> Eff (Error Err : es) (Rep d)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Err -> Eff (Error Err : es) (Rep d)
forall e (es :: [Effect]) a.
(HasCallStack, Error e :> es) =>
e -> Eff es a
throwError (Err -> Eff (Error Err : es) (Rep d))
-> Err -> Eff (Error Err : es) (Rep d)
forall a b. (a -> b) -> a -> b
$ Natural -> Text -> Err
Err Natural
1 Text
"insert failure") (Rep d -> Eff (Error Err : es) (Rep d)
forall a. a -> Eff (Error Err : es) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Rep d -> Eff (Error Err : es) (Rep d))
-> (r -> Rep d) -> r -> Eff (Error Err : es) (Rep d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> Rep d
forall a. a -> Rep a
rep (d -> Rep d) -> (r -> d) -> r -> Rep d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> d
r2d) ([r] -> Maybe r
forall a. [a] -> Maybe a
listToMaybe [r]
ru)
              )
              -<
                (i
tid, u
toUpd)
          Status -> JSON -> h (Rep d) Response
forall body mt (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
 Sets
   h
   '[Status, Body mt body,
     RequiredResponseHeader "Content-Type" Text],
 MIMEType mt) =>
Status -> mt -> h body Response
respondA Status
HTTP.ok200 JSON
JSON -< (Rep d
ru :: Rep d)
      sysOper :: SysOper'
sysOper = Text -> Text -> Maybe Text -> SysOper'
SysOper' Text
"upd" (String -> Text
pack (String -> Text)
-> (Table wfs rfs -> String) -> Table wfs rfs -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableIdentifier -> String
forall a. Show a => a -> String
show (TableIdentifier -> String)
-> (Table wfs rfs -> TableIdentifier) -> Table wfs rfs -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table wfs rfs -> TableIdentifier
forall writeColumns viewColumns.
Table writeColumns viewColumns -> TableIdentifier
tableIdentifier (Table wfs rfs -> Text) -> Table wfs rfs -> Text
forall a b. (a -> b) -> a -> b
$ Table wfs rfs
tbl) Maybe Text
forall a. Maybe a
Nothing
   in (RequestHandler h ts
handler, SysOper'
sysOper)

upd' ::
  forall i u d eff env es h ts. -- (record id) update data eff effects (app env) arrow traits

  ( Reader env :> es,
    IOE :> es,
    eff ~ Eff es,
    StdHandler h eff,
    HaveTraits '[PathVar "id" i] ts,
    Gets h '[Body JSON u],
    Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep d), Body JSON (Rep ())]
  ) =>
  SysOperTargetName ->
  (env -> Pool Connection) ->
  (Connection -> i -> u -> IO d) ->
  (RequestHandler h ts, SysOper')
upd' :: forall i u d (eff :: * -> *) env (es :: [Effect])
       (h :: * -> * -> *) (ts :: [*]).
(Reader env :> es, IOE :> es, eff ~ Eff es, StdHandler h eff,
 HaveTraits '[PathVar "id" i] ts, Gets h '[Body JSON u],
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep d),
     Body JSON (Rep ())]) =>
Text
-> (env -> Pool Connection)
-> (Connection -> i -> u -> IO d)
-> (RequestHandler h ts, SysOper')
upd' Text
tName env -> Pool Connection
envPool Connection -> i -> u -> IO d
oper =
  let handler :: RequestHandler h ts
handler = forall t mt (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(Handler h m, Get h (Body mt t)) =>
mt
-> h (With Request ts, Text) Response
-> Middleware h ts (Body mt t : ts)
requestBody @u JSON
JSON h (With Request ts, Text) Response
forall e (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(Show e, StdHandler h m,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text,
     Body JSON (Rep ())]) =>
h (With Request ts, e) Response
errorHandler Middleware h ts (Body JSON u : ts)
-> Middleware h ts (Body JSON u : ts)
forall a b. (a -> b) -> a -> b
$
        proc With Request (Body JSON u : ts)
request -> do
          let tid :: i
tid = forall {k} (t :: k) a. Tagged t a -> a
forall t a. Tagged t a -> a
pick @(PathVar "id" i) (Tagged (PathVar "id" i) i -> i) -> Tagged (PathVar "id" i) i -> i
forall a b. (a -> b) -> a -> b
$ With Request (Body JSON u : ts)
-> Tagged (PathVar "id" i) (Attribute (PathVar "id" i) Request)
forall a.
With a (Body JSON u : ts)
-> Tagged (PathVar "id" i) (Attribute (PathVar "id" i) a)
forall t (ts :: [*]) a.
HasTrait t ts =>
With a ts -> Tagged t (Attribute t a)
from With Request (Body JSON u : ts)
request
          let toUpd :: u
toUpd = forall {k} (t :: k) a. Tagged t a -> a
forall t a. Tagged t a -> a
pick @(Body JSON u) (Tagged (Body JSON u) u -> u) -> Tagged (Body JSON u) u -> u
forall a b. (a -> b) -> a -> b
$ With Request (Body JSON u : ts)
-> Tagged (Body JSON u) (Attribute (Body JSON u) Request)
forall a.
With a (Body JSON u : ts)
-> Tagged (Body JSON u) (Attribute (Body JSON u) a)
forall t (ts :: [*]) a.
HasTrait t ts =>
With a ts -> Tagged t (Attribute t a)
from With Request (Body JSON u : ts)
request
          Rep d
ru <-
            ((i, u) -> Eff es (Rep d)) -> h (i, u) (Rep d)
forall a b. (a -> Eff es b) -> h a b
forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM
              ( \(i
tid, u
toUpd) -> Eff (Error Err : es) (Rep d) -> Eff es (Rep d)
forall (es :: [Effect]) a.
Eff (Error Err : es) (Rep a) -> Eff es (Rep a)
catchRep (Eff (Error Err : es) (Rep d) -> Eff es (Rep d))
-> Eff (Error Err : es) (Rep d) -> Eff es (Rep d)
forall a b. (a -> b) -> a -> b
$ do
                  Pool Connection
pool <- (env -> Pool Connection) -> Eff (Error Err : es) (Pool Connection)
forall r (es :: [Effect]) a.
(HasCallStack, Reader r :> es) =>
(r -> a) -> Eff es a
asks env -> Pool Connection
envPool
                  IO (Rep d) -> Eff (Error Err : es) (Rep d)
forall a. IO a -> Eff (Error Err : es) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Rep d) -> Eff (Error Err : es) (Rep d))
-> ((Connection -> IO (Rep d)) -> IO (Rep d))
-> (Connection -> IO (Rep d))
-> Eff (Error Err : es) (Rep d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool Connection -> (Connection -> IO (Rep d)) -> IO (Rep d)
forall a r. Pool a -> (a -> IO r) -> IO r
withResource Pool Connection
pool ((Connection -> IO (Rep d)) -> Eff (Error Err : es) (Rep d))
-> (Connection -> IO (Rep d)) -> Eff (Error Err : es) (Rep d)
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> d -> Rep d
forall a. a -> Rep a
rep (d -> Rep d) -> IO d -> IO (Rep d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> i -> u -> IO d
oper Connection
conn i
tid u
toUpd
              )
              -<
                (i
tid, u
toUpd)
          Status -> JSON -> h (Rep d) Response
forall body mt (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
 Sets
   h
   '[Status, Body mt body,
     RequiredResponseHeader "Content-Type" Text],
 MIMEType mt) =>
Status -> mt -> h body Response
respondA Status
HTTP.ok200 JSON
JSON -< (Rep d
ru :: Rep d)
      sysOper :: SysOper'
sysOper = Text -> Text -> Maybe Text -> SysOper'
SysOper' Text
"upd" Text
tName Maybe Text
forall a. Maybe a
Nothing
   in (RequestHandler h ts
handler, SysOper'
sysOper)

del ::
  forall i fi wfs rfs eff env es h ts. -- (record id) (field id) (table write fields) (table read fields) eff effects (app env) arrow traits

  ( Sel1 rfs (Field fi),
    Reader env :> es,
    IOE :> es,
    eff ~ Eff es,
    StdHandler h eff,
    HaveTraits '[PathVar "id" i] ts,
    Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep Text), Body JSON (Rep ())]
  ) =>
  (env -> Pool Connection) ->
  Table wfs rfs ->
  (i -> Field fi) ->
  (RequestHandler h ts, SysOper')
del :: forall i fi wfs rfs (eff :: * -> *) env (es :: [Effect])
       (h :: * -> * -> *) (ts :: [*]).
(Sel1 rfs (Field fi), Reader env :> es, IOE :> es, eff ~ Eff es,
 StdHandler h eff, HaveTraits '[PathVar "id" i] ts,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep Text),
     Body JSON (Rep ())]) =>
(env -> Pool Connection)
-> Table wfs rfs
-> (i -> Field fi)
-> (RequestHandler h ts, SysOper')
del env -> Pool Connection
envPool Table wfs rfs
tbl i -> Field fi
idf =
  let handler :: h (With Request ts) Response
handler = proc With Request ts
request -> do
        let tid :: i
tid = forall {k} (t :: k) a. Tagged t a -> a
forall t a. Tagged t a -> a
pick @(PathVar "id" i) (Tagged (PathVar "id" i) i -> i) -> Tagged (PathVar "id" i) i -> i
forall a b. (a -> b) -> a -> b
$ With Request ts
-> Tagged (PathVar "id" i) (Attribute (PathVar "id" i) Request)
forall a.
With a ts -> Tagged (PathVar "id" i) (Attribute (PathVar "id" i) a)
forall t (ts :: [*]) a.
HasTrait t ts =>
With a ts -> Tagged t (Attribute t a)
from With Request ts
request
        Rep Text
r <-
          (i -> Eff es (Rep Text)) -> h i (Rep Text)
forall a b. (a -> Eff es b) -> h a b
forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM
            ( \i
tid -> do
                Pool Connection
pool <- (env -> Pool Connection) -> Eff es (Pool Connection)
forall r (es :: [Effect]) a.
(HasCallStack, Reader r :> es) =>
(r -> a) -> Eff es a
asks env -> Pool Connection
envPool
                Int64
c <- IO Int64 -> Eff es Int64
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int64 -> Eff es Int64)
-> ((Connection -> IO Int64) -> IO Int64)
-> (Connection -> IO Int64)
-> Eff es Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool Connection -> (Connection -> IO Int64) -> IO Int64
forall a r. Pool a -> (a -> IO r) -> IO r
withResource Pool Connection
pool ((Connection -> IO Int64) -> Eff es Int64)
-> (Connection -> IO Int64) -> Eff es Int64
forall a b. (a -> b) -> a -> b
$
                  \Connection
conn ->
                    Connection -> Delete Int64 -> IO Int64
forall haskells. Connection -> Delete haskells -> IO haskells
runDelete Connection
conn (Delete Int64 -> IO Int64) -> Delete Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$
                      Delete
                        { dTable :: Table wfs rfs
dTable = Table wfs rfs
tbl,
                          dWhere :: rfs -> Field SqlBool
dWhere = (Field fi -> Field fi -> Field SqlBool
forall a. Field a -> Field a -> Field SqlBool
.== i -> Field fi
idf i
tid) (Field fi -> Field SqlBool)
-> (rfs -> Field fi) -> rfs -> Field SqlBool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. rfs -> Field fi
forall a b. Sel1 a b => a -> b
sel1,
                          dReturning :: Returning rfs Int64
dReturning = Returning rfs Int64
forall fieldsR. Returning fieldsR Int64
rCount
                        }
                Rep Text -> Eff es (Rep Text)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rep Text -> Eff es (Rep Text)) -> Rep Text -> Eff es (Rep Text)
forall a b. (a -> b) -> a -> b
$ if Int64
c Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
1 then Rep Text
forall a. Rep a
repOk else Natural -> Text -> Rep Text
forall a. Natural -> Text -> Rep a
repErr Natural
1 Text
"delete failure"
            )
            -<
              i
tid
        Status -> JSON -> h (Rep Text) Response
forall body mt (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
 Sets
   h
   '[Status, Body mt body,
     RequiredResponseHeader "Content-Type" Text],
 MIMEType mt) =>
Status -> mt -> h body Response
respondA Status
HTTP.ok200 JSON
JSON -< (Rep Text
r :: Rep Text)
      sysOper :: SysOper'
sysOper = Text -> Text -> Maybe Text -> SysOper'
SysOper' Text
"get" (String -> Text
pack (String -> Text)
-> (Table wfs rfs -> String) -> Table wfs rfs -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableIdentifier -> String
forall a. Show a => a -> String
show (TableIdentifier -> String)
-> (Table wfs rfs -> TableIdentifier) -> Table wfs rfs -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table wfs rfs -> TableIdentifier
forall writeColumns viewColumns.
Table writeColumns viewColumns -> TableIdentifier
tableIdentifier (Table wfs rfs -> Text) -> Table wfs rfs -> Text
forall a b. (a -> b) -> a -> b
$ Table wfs rfs
tbl) Maybe Text
forall a. Maybe a
Nothing
   in (h (With Request ts) Response
handler, SysOper'
sysOper)