Formatting

Example.brittany-master.hs

-- language extensions
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-- exports
module This.Is.A.Module
  ( -- * ContactRequest
    DataType
  , cwInboxStatus
  , ContactRequestUserEmail
  , ContactRequestCreate
  , ContactRequestExt(..)
  , crIntId
  , pattern (:%:)
  , crUser
  , (:.)
-- * Database stuff
  , CrResolved(..)
  , B.DBUpdate(..)
  , crResSFPagedInbox
  , crOperateReturning
  , crOperateBusIdReturningResolved -- * Inbox
  )
where

-- imports
import qualified Control.Storage               as S
                                         hiding ( Asc
                                                , Desc
                                                )
import           Conf.ID                        ( MonadIDGen(..) )
import qualified Data.Business.Transactions.User
                                               as U
import           Control.Lens            hiding ( ilike
                                                , (.=)
                                                )
import "package2" Control.Lens           hiding ( ilike
                                                , (.=)
                                                )
import qualified "package" Data.Business.Transactions
                                               as Trans
import qualified Data.Business.Transactions2   as Trans2
import qualified Data.Business.Transactions2   as Trans2
import qualified Data.Business.Transactions.History.Events.Something
                                               as Events
import           Control.Resolution             ( MonadResolve
                                                , Resolution(..)
                                                , Something
                                                , SomethingElse
                                                , test
                                                , test2
                                                , OtherThing
                                                )
import qualified Data.Business.Transactions.Search
                                               as Search
import           CPrelude                hiding ( trans )


-- datatypes
data Something = Something
  { _stdfgdfgljsfgsfgsdfgsdfgsdfgsdfgs :: !Something
  }
  deriving (Eq, Show, Generic, ToJSON, FromJSON)

-- | Error type for things that can go wrong for ContactRequests
data ContactRequestErr
  -- | Contact request not found
  = NoSuchCr !Trans.CrId
  -- | Other storage error
  | CrStorageErr !Text

data ContactRequestErr = NoSuchCr !Trans.CrId | CrStorageErr !Text

data
  ContactRequest' internalId externalId business message langCode createdAt updatedAt inboxStatus user
  = ContactRequest
    { _crIntId       :: !internalId -- ^ Unique id of the booking request, exposed to the users of CA 
    , _crExtId       :: !externalId -- ^ Unique external id of the booking request, exposed publicly.
    , _crBusiness    :: !business
    , _crMessage     :: !message -- ^ Non-empty message in the request
    , _crLangCode    :: !langCode -- ^ Language of the request's message
    , _crCreatedAt   :: !createdAt -- ^ Time at which this request was created in the system
    , _crUpdatedAt   :: !updatedAt -- ^ Last updated time of this request 
    , _crInboxStatus :: !inboxStatus -- ^ Status of this request in the business' inbox.
    , _crUser        :: !user -- ^ The WebsiteUser; or requester 
    }
  deriving (Show, Eq, Generic)

-- | haddock1
data Foo (t::k) where
  -- | haddock2
  Foo ::A -> Foo B
  -- | haddock3
  Bar ::B -> Foo C

-- long type synonym
-- | Sqls side of things (how CR's are stored in the DB)
-- note that this only contains a user email 
type ContactRequestUserEmailField
  = ContactRequest'
      Trans.CrIntIdField
      Trans.CrExtIdField
      B.CompanyIdField
      (Field J.PGNonEmptyText)
      LangCodeField
      (Field PGTimestamptz)
      (FieldNullable PGTimestamptz)
      (Field Trans.PGInboxStatus)
      U.UserEmailField

-- misc
-- | Outgoing requests need to be serialized
instance ToJSON ContactRequest where
  toJSON cr@ContactRequest {..} = object
    [ "id" .= (cr ^. crTransactionId)
    , "internal_id" .= (_crIntId ^. Trans.unCrIntId . to show :: Text)
    , "created" .= _crCreatedAt
    , "updated" .= _crUpdatedAt
    , "message" .= _crMessage
    , "lang_code" .= _crLangCode
    ]

-- | Outgoing requests need to be serialized
instance ToJSON ContactRequest where
  toJSON cr@ContactRequest {..} = object
    [ "id" .= (cr ^. crTransactionId)
    , "internal_id" .= (_crIntId ^. Trans.unCrIntId . to show :: Text)
    , "created" .= _crCreatedAt
    , "updated" .= _crUpdatedAt
    , "message" .= _crMessage
    , "lang_code" .= _crLangCode
    ]

instance ToJSON CrResolved where
  toJSON CrResolved {..} =
    object ["contact_request" .= _crResRequest, "history" .= _crResHistory]



-- arrows
instance MonadResolve m => Resolution ContactRequest m where
  type Resolved ContactRequest = CrResolved

  resolve cr = do
    mResolved <- SL.headMay <$> resolveMult [cr]
    resolved  <- liftMaybe' cannotResolve mResolved
    return resolved
    where cannotResolve = CrStorageErr $ "Unable to resolve: " <> show cr

  resolveMult crs = do
    (SL.SList mEvts) <- S.runDBTransRuntimeThrow . Events.crEvents $ intIds
    return
      . SL.sList
      $ [ CrResolved cr (maybe [] toList es) | (cr, es) <- zip crs mEvts ]
    where intIds = _crIntId <$> crs

--brittany-disable-next-binding
-- | Ensure a CR matches the given BusinessId; throw errors otherwise.
-- We throw a non-informative NotFound error, this is done to avoid potentially leaking IDs.
ensureMatchesBusiness :: Trans.CrId -> B.BusinessIdComp -> S.DBTrans (S.DBId ContactRequest)
ensureMatchesBusiness rid busId = do
  mId <- selectCr
  maybe (throwError' . NoSuchCr $ rid) (return . Trans.IntId) mId
  where
    selectCr = S.queryFirst $ proc () -> do
      cr <- selectTable contactRequestTable -< ()
      restrict -< idEq rid cr .&& busIdEq busId cr
      returnA -< cr ^. crIntId


-- | Ensures that the `ContactRequest` belongs to the given business.
busIdEq :: B.BusinessIdComp -> ContactRequestUserEmailField -> Column PGBool
busIdEq busId ContactRequest {..} = case busId of
  B.BCCompanyId cid -> _crBusiness ^. to (.=== constant cid)
  B.BCCompLoc   cl  -> _crBusiness .=== constant (cl ^. B.clCompany)

-- brittany-disable-next-binding 
-- | Select an `ContactRequestField` using joins across multiple tables using a predicate on each of the joined tables 
selectCR
  :: (ContactRequestUserEmailField -> U.UserField -> B.CompanyIdField -> Field PGBool) -- ^ Predicate 
  -> Select ContactRequestField
selectCR predicate = proc () -> do
  cr@ContactRequest {..} <- selectTable contactRequestTable -< ()
  [email protected] {..} <- selectTable U.userTable -< ()
  restrict -<
    predicate cr u _crBusiness -- first ensure that the predicate checks out 
    .&& _crUser .=== _uId ^. U.uidEmail -- The CR's user email must match a row on the user's table 
    .&& _crBusiness .=== _uId ^. U.uidBusiness -- the company of the CR must match the company of the user.
  returnA -< cr & crUser .~ u


-- long function
-- | Get fully resolved `LTBRResolved` after some filtering and pagination
crResSFPaged
  :: MonadResolve m
  => Search.Paginate
  -> Search.SortFilt
  -> Search.BusinessFilt
  -> m (Search.Page CrResolved)
crResSFPaged pg sf bid
  | sfIncludesItemType = do
    crs :: [ContactRequest] <- execSelect (crSelectSortFiltPaged pg sf bid)
    Search.page pg . SL.catSLMaybes <$> resolveMult crs
  | otherwise = return $ mempty & Search.pgPaginate .~ pg
 where
  sfIncludesItemType =
    Trans.ContactRequest `elem` sf ^. Search.sfFilter . Search.fInboxItemTypes

-- brittany-disable-next-binding
updateRequest rid cond eType ctx setRow = do
    t <- liftIO getCurrentTime
    mIntId <- findRequest
    case mIntId of
      Just intId ->
        let event = Events.crCreate $ Events.TransEventInvariant intId eType t ctx
        in recordingUpdatedTime (Just t) . Events.recordingEvent event $ fmap (S.TopLevel . Trans.IntId) <$> S.updateReturning contactRequestTable setRow (idEq rid) _crIntId
      Nothing -> throwError' . NoSuchCr $ rid
    where
      -- setStatus  = set tbrStatus (toFields s)
      findRequest = S.queryFirst $ proc () -> do
        cr <- selectTable contactRequestTable -< ()
        restrict -< idEq rid cr .&& cond cr
        returnA -< cr ^. crIntId

Example.hs

-- language extensions
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-- exports
module This.Is.A.Module
  ( -- * ContactRequest
    DataType
  , cwInboxStatus , ContactRequestUserEmail , ContactRequestCreate , ContactRequestExt(..)
  , crIntId
  , pattern (:%:)
  , crUser
  , (:.)
-- * Database stuff
  , CrResolved(..)
  , B.DBUpdate(..)
  , crResSFPagedInbox
  , crOperateReturning , crOperateBusIdReturningResolved -- * Inbox
  )
  where
  
-- imports
import qualified Control.Storage               as S hiding ( Asc , Desc)
import           Conf.ID                        ( MonadIDGen(..) )
import qualified Data.Business.Transactions.User as U
import           Control.Lens            hiding ( ilike , (.=))
import           "package2" Control.Lens            hiding ( ilike , (.=))
import qualified "package" Data.Business.Transactions    as Trans
import qualified Data.Business.Transactions2    as Trans2
import qualified Data.Business.Transactions2    as Trans2
import qualified Data.Business.Transactions.History.Events.Something as Events
import           Control.Resolution             ( MonadResolve , Resolution(..), Something, SomethingElse, test, test2, OtherThing)
import qualified Data.Business.Transactions.Search as Search
import           CPrelude                hiding ( trans )


-- datatypes
data Something = Something { _stdfgdfgljsfgsfgsdfgsdfgsdfgsdfgs :: !Something } deriving (Eq, Show, Generic, ToJSON, FromJSON)

-- | Error type for things that can go wrong for ContactRequests
data ContactRequestErr
  -- | Contact request not found
  = NoSuchCr !Trans.CrId
  -- | Other storage error
  | CrStorageErr !Text

data ContactRequestErr = NoSuchCr !Trans.CrId | CrStorageErr !Text

data ContactRequest' internalId externalId business message langCode createdAt updatedAt inboxStatus user = ContactRequest
  { _crIntId :: !internalId -- ^ Unique id of the booking request, exposed to the users of CA 
  , _crExtId :: !externalId -- ^ Unique external id of the booking request, exposed publicly.
  , _crBusiness  :: !business
  , _crMessage :: !message -- ^ Non-empty message in the request
  , _crLangCode  :: !langCode -- ^ Language of the request's message
  , _crCreatedAt   :: !createdAt -- ^ Time at which this request was created in the system
  , _crUpdatedAt :: !updatedAt -- ^ Last updated time of this request 
  , _crInboxStatus :: !inboxStatus -- ^ Status of this request in the business' inbox.
  , _crUser    :: !user -- ^ The WebsiteUser; or requester 
  } deriving (Show, Eq, Generic)

-- | haddock1
data Foo (t::k) where
  -- | haddock2
  Foo :: A -> Foo B
  -- | haddock3
  Bar :: B -> Foo C

-- long type synonym
-- | Sqls side of things (how CR's are stored in the DB)
-- note that this only contains a user email 
type ContactRequestUserEmailField = ContactRequest' Trans.CrIntIdField Trans.CrExtIdField B.CompanyIdField (Field J.PGNonEmptyText) LangCodeField (Field PGTimestamptz) (FieldNullable PGTimestamptz) (Field Trans.PGInboxStatus) U.UserEmailField

-- misc
-- | Outgoing requests need to be serialized
instance ToJSON ContactRequest where
  toJSON cr@ContactRequest {..} = object
    [ "id" .= (cr ^. crTransactionId) , "internal_id" .= (_crIntId ^. Trans.unCrIntId . to show :: Text) , "created" .= _crCreatedAt , "updated" .= _crUpdatedAt , "message" .= _crMessage , "lang_code" .= _crLangCode]

-- | Outgoing requests need to be serialized
instance ToJSON ContactRequest where
  toJSON cr@ContactRequest {..} = object
    [ "id" .= (cr ^. crTransactionId)
    , "internal_id" .= (_crIntId ^. Trans.unCrIntId . to show :: Text)
    , "created" .= _crCreatedAt
    , "updated" .= _crUpdatedAt
    , "message" .= _crMessage , "lang_code" .= _crLangCode]

instance ToJSON CrResolved where
  toJSON CrResolved {..} = object [ "contact_request" .= _crResRequest , "history" .= _crResHistory]



-- arrows
instance MonadResolve m => Resolution ContactRequest m where
  type Resolved ContactRequest = CrResolved

  resolve cr = do
    mResolved <- SL.headMay <$> resolveMult [cr]
    resolved <- liftMaybe' cannotResolve mResolved
    return resolved
   where
     cannotResolve = CrStorageErr $ "Unable to resolve: " <> show cr

  resolveMult crs = do
    (SL.SList mEvts) <- S.runDBTransRuntimeThrow . Events.crEvents $ intIds
    return . SL.sList $ [ CrResolved cr (maybe [] toList es) | (cr, es) <- zip crs mEvts]
   where intIds = _crIntId <$> crs

--brittany-disable-next-binding
-- | Ensure a CR matches the given BusinessId; throw errors otherwise.
-- We throw a non-informative NotFound error, this is done to avoid potentially leaking IDs.
ensureMatchesBusiness :: Trans.CrId -> B.BusinessIdComp -> S.DBTrans (S.DBId ContactRequest)
ensureMatchesBusiness rid busId = do
  mId <- selectCr
  maybe (throwError' . NoSuchCr $ rid) (return . Trans.IntId) mId
  where
    selectCr = S.queryFirst $ proc () -> do
      cr <- selectTable contactRequestTable -< ()
      restrict -< idEq rid cr .&& busIdEq busId cr
      returnA -< cr ^. crIntId


-- | Ensures that the `ContactRequest` belongs to the given business.
busIdEq :: B.BusinessIdComp -> ContactRequestUserEmailField -> Column PGBool
busIdEq busId ContactRequest {..} = case busId of
  B.BCCompanyId cid -> _crBusiness ^. to (.=== constant cid)
  B.BCCompLoc   cl  -> _crBusiness .=== constant (cl ^. B.clCompany)

-- brittany-disable-next-binding 
-- | Select an `ContactRequestField` using joins across multiple tables using a predicate on each of the joined tables 
selectCR
  :: (ContactRequestUserEmailField -> U.UserField -> B.CompanyIdField -> Field PGBool) -- ^ Predicate 
  -> Select ContactRequestField
selectCR predicate = proc () -> do
  cr@ContactRequest {..} <- selectTable contactRequestTable -< ()
  [email protected] {..} <- selectTable U.userTable -< ()
  restrict -<
    predicate cr u _crBusiness -- first ensure that the predicate checks out 
    .&& _crUser .=== _uId ^. U.uidEmail -- The CR's user email must match a row on the user's table 
    .&& _crBusiness .=== _uId ^. U.uidBusiness -- the company of the CR must match the company of the user.
  returnA -< cr & crUser .~ u


-- long function
-- | Get fully resolved `LTBRResolved` after some filtering and pagination
crResSFPaged :: MonadResolve m => Search.Paginate -> Search.SortFilt -> Search.BusinessFilt -> m (Search.Page CrResolved)
crResSFPaged pg sf bid
  | sfIncludesItemType = do
    crs :: [ContactRequest] <- execSelect (crSelectSortFiltPaged pg sf bid)
    Search.page pg . SL.catSLMaybes <$> resolveMult crs
  | otherwise = return $ mempty & Search.pgPaginate .~ pg
 where
  sfIncludesItemType =
    Trans.ContactRequest `elem` sf ^. Search.sfFilter . Search.fInboxItemTypes

-- brittany-disable-next-binding
updateRequest rid cond eType ctx setRow = do
    t <- liftIO getCurrentTime
    mIntId <- findRequest
    case mIntId of
      Just intId ->
        let event = Events.crCreate $ Events.TransEventInvariant intId eType t ctx
        in recordingUpdatedTime (Just t) . Events.recordingEvent event $ fmap (S.TopLevel . Trans.IntId) <$> S.updateReturning contactRequestTable setRow (idEq rid) _crIntId
      Nothing -> throwError' . NoSuchCr $ rid
    where
      -- setStatus  = set tbrStatus (toFields s)
      findRequest = S.queryFirst $ proc () -> do
        cr <- selectTable contactRequestTable -< ()
        restrict -< idEq rid cr .&& cond cr
        returnA -< cr ^. crIntId

Example.ormolu.hs

{-# LANGUAGE Arrows #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}

-- language extensions

-- exports
module This.Is.A.Module
  ( -- * ContactRequest
    DataType,
    cwInboxStatus,
    ContactRequestUserEmail,
    ContactRequestCreate,
    ContactRequestExt (..),
    crIntId,
    pattern (:%:),
    crUser,
    (:.),

    -- * Database stuff
    CrResolved (..),
    B.DBUpdate (..),
    crResSFPagedInbox,
    crOperateReturning,
    crOperateBusIdReturningResolved,

    -- * Inbox
  )
where

-- imports

import CPrelude hiding (trans)
import Conf.ID (MonadIDGen (..))
import Control.Lens hiding ((.=), ilike)
import "package2" Control.Lens hiding ((.=), ilike)
import Control.Resolution (MonadResolve, OtherThing, Resolution (..), Something, SomethingElse, test, test2)
import qualified Control.Storage as S hiding (Asc, Desc)
import qualified "package" Data.Business.Transactions as Trans
import qualified Data.Business.Transactions.History.Events.Something as Events
import qualified Data.Business.Transactions.Search as Search
import qualified Data.Business.Transactions.User as U
import qualified Data.Business.Transactions2 as Trans2
import qualified Data.Business.Transactions2 as Trans2

-- datatypes
data Something = Something {_stdfgdfgljsfgsfgsdfgsdfgsdfgsdfgs :: !Something} deriving (Eq, Show, Generic, ToJSON, FromJSON)

-- | Error type for things that can go wrong for ContactRequests
data ContactRequestErr
  = -- | Contact request not found
    NoSuchCr !Trans.CrId
  | -- | Other storage error
    CrStorageErr !Text

data ContactRequestErr = NoSuchCr !Trans.CrId | CrStorageErr !Text

data ContactRequest' internalId externalId business message langCode createdAt updatedAt inboxStatus user
  = ContactRequest
      { -- | Unique id of the booking request, exposed to the users of CA
        _crIntId :: !internalId,
        -- | Unique external id of the booking request, exposed publicly.
        _crExtId :: !externalId,
        _crBusiness :: !business,
        -- | Non-empty message in the request
        _crMessage :: !message,
        -- | Language of the request's message
        _crLangCode :: !langCode,
        -- | Time at which this request was created in the system
        _crCreatedAt :: !createdAt,
        -- | Last updated time of this request
        _crUpdatedAt :: !updatedAt,
        -- | Status of this request in the business' inbox.
        _crInboxStatus :: !inboxStatus,
        -- | The WebsiteUser; or requester
        _crUser :: !user
      }
  deriving (Show, Eq, Generic)

-- | haddock1
data Foo (t :: k) where
  -- | haddock2
  Foo :: A -> Foo B
  -- | haddock3
  Bar :: B -> Foo C

-- long type synonym

-- | Sqls side of things (how CR's are stored in the DB)
-- note that this only contains a user email
type ContactRequestUserEmailField = ContactRequest' Trans.CrIntIdField Trans.CrExtIdField B.CompanyIdField (Field J.PGNonEmptyText) LangCodeField (Field PGTimestamptz) (FieldNullable PGTimestamptz) (Field Trans.PGInboxStatus) U.UserEmailField

-- misc

-- | Outgoing requests need to be serialized
instance ToJSON ContactRequest where
  toJSON cr@ContactRequest {..} =
    object
      ["id" .= (cr ^. crTransactionId), "internal_id" .= (_crIntId ^. Trans.unCrIntId . to show :: Text), "created" .= _crCreatedAt, "updated" .= _crUpdatedAt, "message" .= _crMessage, "lang_code" .= _crLangCode]

-- | Outgoing requests need to be serialized
instance ToJSON ContactRequest where
  toJSON cr@ContactRequest {..} =
    object
      [ "id" .= (cr ^. crTransactionId),
        "internal_id" .= (_crIntId ^. Trans.unCrIntId . to show :: Text),
        "created" .= _crCreatedAt,
        "updated" .= _crUpdatedAt,
        "message" .= _crMessage,
        "lang_code" .= _crLangCode
      ]

instance ToJSON CrResolved where
  toJSON CrResolved {..} = object ["contact_request" .= _crResRequest, "history" .= _crResHistory]

-- arrows
instance MonadResolve m => Resolution ContactRequest m where
  type Resolved ContactRequest = CrResolved

  resolve cr = do
    mResolved <- SL.headMay <$> resolveMult [cr]
    resolved <- liftMaybe' cannotResolve mResolved
    return resolved
    where
      cannotResolve = CrStorageErr $ "Unable to resolve: " <> show cr

  resolveMult crs = do
    (SL.SList mEvts) <- S.runDBTransRuntimeThrow . Events.crEvents $ intIds
    return . SL.sList $ [CrResolved cr (maybe [] toList es) | (cr, es) <- zip crs mEvts]
    where
      intIds = _crIntId <$> crs

--brittany-disable-next-binding

-- | Ensure a CR matches the given BusinessId; throw errors otherwise.
-- We throw a non-informative NotFound error, this is done to avoid potentially leaking IDs.
ensureMatchesBusiness :: Trans.CrId -> B.BusinessIdComp -> S.DBTrans (S.DBId ContactRequest)
ensureMatchesBusiness rid busId = do
  mId <- selectCr
  maybe (throwError' . NoSuchCr $ rid) (return . Trans.IntId) mId
  where
    selectCr = S.queryFirst $ proc () -> do
      cr <- selectTable contactRequestTable -< ()
      restrict -< idEq rid cr .&& busIdEq busId cr
      returnA -< cr ^. crIntId

-- | Ensures that the `ContactRequest` belongs to the given business.
busIdEq :: B.BusinessIdComp -> ContactRequestUserEmailField -> Column PGBool
busIdEq busId ContactRequest {..} = case busId of
  B.BCCompanyId cid -> _crBusiness ^. to (.=== constant cid)
  B.BCCompLoc cl -> _crBusiness .=== constant (cl ^. B.clCompany)

-- brittany-disable-next-binding

-- | Select an `ContactRequestField` using joins across multiple tables using a predicate on each of the joined tables
selectCR ::
  -- | Predicate
  (ContactRequestUserEmailField -> U.UserField -> B.CompanyIdField -> Field PGBool) ->
  Select ContactRequestField
selectCR predicate = proc () -> do
  cr@ContactRequest {..} <- selectTable contactRequestTable -< ()
  [email protected] {..} <- selectTable U.userTable -< ()
  restrict -<
    predicate cr u _crBusiness -- first ensure that the predicate checks out
      .&& _crUser .=== _uId ^. U.uidEmail -- The CR's user email must match a row on the user's table
      .&& _crBusiness .=== _uId ^. U.uidBusiness -- the company of the CR must match the company of the user.
  returnA -< cr & crUser .~ u

-- long function

-- | Get fully resolved `LTBRResolved` after some filtering and pagination
crResSFPaged :: MonadResolve m => Search.Paginate -> Search.SortFilt -> Search.BusinessFilt -> m (Search.Page CrResolved)
crResSFPaged pg sf bid
  | sfIncludesItemType = do
    crs :: [ContactRequest] <- execSelect (crSelectSortFiltPaged pg sf bid)
    Search.page pg . SL.catSLMaybes <$> resolveMult crs
  | otherwise = return $ mempty & Search.pgPaginate .~ pg
  where
    sfIncludesItemType =
      Trans.ContactRequest `elem` sf ^. Search.sfFilter . Search.fInboxItemTypes

-- brittany-disable-next-binding
updateRequest rid cond eType ctx setRow = do
  t <- liftIO getCurrentTime
  mIntId <- findRequest
  case mIntId of
    Just intId ->
      let event = Events.crCreate $ Events.TransEventInvariant intId eType t ctx
       in recordingUpdatedTime (Just t) . Events.recordingEvent event $ fmap (S.TopLevel . Trans.IntId) <$> S.updateReturning contactRequestTable setRow (idEq rid) _crIntId
    Nothing -> throwError' . NoSuchCr $ rid
  where
    -- setStatus  = set tbrStatus (toFields s)
    findRequest = S.queryFirst $ proc () -> do
      cr <- selectTable contactRequestTable -< ()
      restrict -< idEq rid cr .&& cond cr
      returnA -< cr ^. crIntId

Example.stylish-haskell.hs

-- language extensions
{-# LANGUAGE Arrows                #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE InstanceSigs          #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PackageImports        #-}
{-# LANGUAGE PatternSynonyms       #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
-- exports
module This.Is.A.Module
  ( -- * ContactRequest
    DataType
  , cwInboxStatus , ContactRequestUserEmail , ContactRequestCreate , ContactRequestExt(..)
  , crIntId
  , pattern (:%:)
  , crUser
  , (:.)
-- * Database stuff
  , CrResolved(..)
  , B.DBUpdate(..)
  , crResSFPagedInbox
  , crOperateReturning , crOperateBusIdReturningResolved -- * Inbox
  )
  where

-- imports
import           Conf.ID                                             (MonadIDGen (..))
import           Control.Lens                                        hiding
                                                                      (ilike,
                                                                      (.=))
import           "package2" Control.Lens                             hiding
                                                                      (ilike,
                                                                      (.=))
import           Control.Resolution                                  (MonadResolve,
                                                                      OtherThing,
                                                                      Resolution (..),
                                                                      Something,
                                                                      SomethingElse,
                                                                      test,
                                                                      test2)
import qualified Control.Storage                                     as S hiding
                                                                           (Asc,
                                                                           Desc)
import           CPrelude                                            hiding
                                                                      (trans)
import qualified "package" Data.Business.Transactions                as Trans
import qualified Data.Business.Transactions.History.Events.Something as Events
import qualified Data.Business.Transactions.Search                   as Search
import qualified Data.Business.Transactions.User                     as U
import qualified Data.Business.Transactions2                         as Trans2
import qualified Data.Business.Transactions2                         as Trans2


-- datatypes
data Something = Something { _stdfgdfgljsfgsfgsdfgsdfgsdfgsdfgs :: !Something } deriving (Eq, Show, Generic, ToJSON, FromJSON)

-- | Error type for things that can go wrong for ContactRequests
data ContactRequestErr
  -- | Contact request not found
  = NoSuchCr !Trans.CrId
  -- | Other storage error
  | CrStorageErr !Text

data ContactRequestErr = NoSuchCr !Trans.CrId | CrStorageErr !Text

data ContactRequest' internalId externalId business message langCode createdAt updatedAt inboxStatus user = ContactRequest
  { _crIntId       :: !internalId -- ^ Unique id of the booking request, exposed to the users of CA
  , _crExtId       :: !externalId -- ^ Unique external id of the booking request, exposed publicly.
  , _crBusiness    :: !business
  , _crMessage     :: !message -- ^ Non-empty message in the request
  , _crLangCode    :: !langCode -- ^ Language of the request's message
  , _crCreatedAt   :: !createdAt -- ^ Time at which this request was created in the system
  , _crUpdatedAt   :: !updatedAt -- ^ Last updated time of this request
  , _crInboxStatus :: !inboxStatus -- ^ Status of this request in the business' inbox.
  , _crUser        :: !user -- ^ The WebsiteUser; or requester
  } deriving (Show, Eq, Generic)

-- | haddock1
data Foo (t::k) where
  -- | haddock2
  Foo :: A -> Foo B
  -- | haddock3
  Bar :: B -> Foo C

-- long type synonym
-- | Sqls side of things (how CR's are stored in the DB)
-- note that this only contains a user email
type ContactRequestUserEmailField = ContactRequest' Trans.CrIntIdField Trans.CrExtIdField B.CompanyIdField (Field J.PGNonEmptyText) LangCodeField (Field PGTimestamptz) (FieldNullable PGTimestamptz) (Field Trans.PGInboxStatus) U.UserEmailField

-- misc
-- | Outgoing requests need to be serialized
instance ToJSON ContactRequest where
  toJSON cr@ContactRequest {..} = object
    [ "id" .= (cr ^. crTransactionId) , "internal_id" .= (_crIntId ^. Trans.unCrIntId . to show :: Text) , "created" .= _crCreatedAt , "updated" .= _crUpdatedAt , "message" .= _crMessage , "lang_code" .= _crLangCode]

-- | Outgoing requests need to be serialized
instance ToJSON ContactRequest where
  toJSON cr@ContactRequest {..} = object
    [ "id" .= (cr ^. crTransactionId)
    , "internal_id" .= (_crIntId ^. Trans.unCrIntId . to show :: Text)
    , "created" .= _crCreatedAt
    , "updated" .= _crUpdatedAt
    , "message" .= _crMessage , "lang_code" .= _crLangCode]

instance ToJSON CrResolved where
  toJSON CrResolved {..} = object [ "contact_request" .= _crResRequest , "history" .= _crResHistory]



-- arrows
instance MonadResolve m => Resolution ContactRequest m where
  type Resolved ContactRequest = CrResolved

  resolve cr = do
    mResolved <- SL.headMay <$> resolveMult [cr]
    resolved <- liftMaybe' cannotResolve mResolved
    return resolved
   where
     cannotResolve = CrStorageErr $ "Unable to resolve: " <> show cr

  resolveMult crs = do
    (SL.SList mEvts) <- S.runDBTransRuntimeThrow . Events.crEvents $ intIds
    return . SL.sList $ [ CrResolved cr (maybe [] toList es) | (cr, es) <- zip crs mEvts]
   where intIds = _crIntId <$> crs

--brittany-disable-next-binding
-- | Ensure a CR matches the given BusinessId; throw errors otherwise.
-- We throw a non-informative NotFound error, this is done to avoid potentially leaking IDs.
ensureMatchesBusiness :: Trans.CrId -> B.BusinessIdComp -> S.DBTrans (S.DBId ContactRequest)
ensureMatchesBusiness rid busId = do
  mId <- selectCr
  maybe (throwError' . NoSuchCr $ rid) (return . Trans.IntId) mId
  where
    selectCr = S.queryFirst $ proc () -> do
      cr <- selectTable contactRequestTable -< ()
      restrict -< idEq rid cr .&& busIdEq busId cr
      returnA -< cr ^. crIntId


-- | Ensures that the `ContactRequest` belongs to the given business.
busIdEq :: B.BusinessIdComp -> ContactRequestUserEmailField -> Column PGBool
busIdEq busId ContactRequest {..} = case busId of
  B.BCCompanyId cid -> _crBusiness ^. to (.=== constant cid)
  B.BCCompLoc   cl  -> _crBusiness .=== constant (cl ^. B.clCompany)

-- brittany-disable-next-binding
-- | Select an `ContactRequestField` using joins across multiple tables using a predicate on each of the joined tables
selectCR
  :: (ContactRequestUserEmailField -> U.UserField -> B.CompanyIdField -> Field PGBool) -- ^ Predicate
  -> Select ContactRequestField
selectCR predicate = proc () -> do
  cr@ContactRequest {..} <- selectTable contactRequestTable -< ()
  [email protected] {..} <- selectTable U.userTable -< ()
  restrict -<
    predicate cr u _crBusiness -- first ensure that the predicate checks out
    .&& _crUser .=== _uId ^. U.uidEmail -- The CR's user email must match a row on the user's table
    .&& _crBusiness .=== _uId ^. U.uidBusiness -- the company of the CR must match the company of the user.
  returnA -< cr & crUser .~ u


-- long function
-- | Get fully resolved `LTBRResolved` after some filtering and pagination
crResSFPaged :: MonadResolve m => Search.Paginate -> Search.SortFilt -> Search.BusinessFilt -> m (Search.Page CrResolved)
crResSFPaged pg sf bid
  | sfIncludesItemType = do
    crs :: [ContactRequest] <- execSelect (crSelectSortFiltPaged pg sf bid)
    Search.page pg . SL.catSLMaybes <$> resolveMult crs
  | otherwise = return $ mempty & Search.pgPaginate .~ pg
 where
  sfIncludesItemType =
    Trans.ContactRequest `elem` sf ^. Search.sfFilter . Search.fInboxItemTypes

-- brittany-disable-next-binding
updateRequest rid cond eType ctx setRow = do
    t <- liftIO getCurrentTime
    mIntId <- findRequest
    case mIntId of
      Just intId ->
        let event = Events.crCreate $ Events.TransEventInvariant intId eType t ctx
        in recordingUpdatedTime (Just t) . Events.recordingEvent event $ fmap (S.TopLevel . Trans.IntId) <$> S.updateReturning contactRequestTable setRow (idEq rid) _crIntId
      Nothing -> throwError' . NoSuchCr $ rid
    where
      -- setStatus  = set tbrStatus (toFields s)
      findRequest = S.queryFirst $ proc () -> do
        cr <- selectTable contactRequestTable -< ()
        restrict -< idEq rid cr .&& cond cr
        returnA -< cr ^. crIntId