73NDXDEZRMK672GHSTC3CI6YHXFZ2GGJI5IKQGHKFDZKTNSQXLLQC
5ZSKPQ3KY6T6O5S6T6HW4OHJMQXA72WKJSJJMGKGX2WMFTNZ7EGAC
DFOBMSAODB3NKW37B272ZXA2ML5HMIH3N3C4GT2DPEQS7ZFK4SNAC
NEDDHXUK3GNFMOFO3KLU7NRIHCTYNWBT3D6HTKZAOXFDE6HMDZ6AC
IZEVQF627FA7VV25KJAWYWGGC35LZUUBBQRPN5ZAINTQLPEDRTEAC
NAS4BFL43SIUAAC663R6VFBHQ2DKI45K6Y6ZKVQI7S5547HBAN7QC
LD4GLVSF6YTA7OZWIGJ45H6TUXGM4WKUIYXKWQFNUP36WDMYSMXAC
RN7EI6INGUUHGMNY5RU3NH56WPLRZY5ZMYDNFMNE3TGV4ESFLQIAC
Z7KS5XHHC6PAMTVBHXY7KUSS3BWAOU6FSYIITUCFOOJZU4OUJHBAC
GCVQD44VRPQVKPZEPIC4AOIXLJIG2ZMV3QI2Y7KALUT6NVUBSGSAC
5OI44E4EEVYOMHDWNK2WA7K4L4JWRWCUJUNN2UAUGE5VY4W7GTNAC
HALRDT2F22DAQ54M334YSKD2XJCAXDXEZPDKGMOWKH7XELBAS6MAC
M4KM76DGO77VC4O6N5FFA5MTZH5GI5AJ3OUJU7INLAOY2M3LRLLAC
2XQD6KKKD6QVHFHAEMVE3XXY7X2T7BLTLL7XIILZAXNJJH2YONUQC
EKY7U7SKPF45OOUAHJBEQKXSUXWOHFBQFFVJWPBN5ARFJUFM2BPAC
KEP5WUFJXTMKRRNZLYTGYYWA4VLFCMHTKTJYF5EA5IWBYFMU6WYQC
QMRKFEPGFBCEWAIXPEIG5ILKAJ2JH5L3TOITHR4HNJXK5FN3KXBQC
TNR3TEHKVADAEZSTOD2XLSUTSW5AWST2YUW4CWK5KE7DSC6XHZNAC
O5FVTOM6YFBLEPF3S576K6IMT6ZZ5VQCSB3YVXNS4CKBITKCRZ7AC
A6HKMINBNGQLLX4QJMYWKQ4JAEHVJ4HIRVDKPPDI3FJUO2AAB7OQC
3QVT6MA6I2CILQH3LUZABS4YQ7MN6CNRYTDRVS376OOHTPLYTFJAC
7HPY3QPFPN35PSPUBVNW2GTFB3CBQZBST4J2BAVJ7QMXLIUN52JAC
RPAJLHMTUJU4AYNBOHVGHGGB4NY2NLY3BVPYN5FMWB3ZIMAUQHCQC
ZP62WC472OTQETO2HTHIQIPO57XZIWVKPA4KL62GYU4OZDMB6NSAC
ZITLSTYXUOESFELOW3DLBKWKMSS5ZJYCTKMK4Z44WGIYAKYSMMVAC
NLZ3JXLOOIL37O3RRQWXHNPNSNEOOLPD6MCB754BEBECQB3KGR2AC
64C6AWH66FDKU6UE6Z6JPX2J2GBM2JOPTH2GL6LHKAIUBGNGDZ5AC
BROSTG5KP3NUNLSYPVQID254TE47E5RKQAKLPIY7PGWETE6JNMTAC
data Billable (p :: *) (c :: *) = Billable
recurrenceName :: Recurrence -> Text
recurrenceName Annually = "annually"
recurrenceName (Monthly _) = "monthly"
recurrenceName SemiMonthly = "semimonthly"
recurrenceName (Weekly _) = "weekly"
recurrenceName OneTime = "onetime"
recurrenceCount :: Recurrence -> Maybe Int
recurrenceCount Annually = Nothing
recurrenceCount (Monthly i) = Just i
recurrenceCount SemiMonthly = Nothing
recurrenceCount (Weekly i) = Just i
recurrenceCount OneTime = Nothing
data Billable' (p :: *) (u :: *) (c :: *) = Billable
newtype SubscriptionId = SubscriptionId UUID deriving (Show, Eq)
recurrenceParser :: RowParser BI.Recurrence
recurrenceParser =
let prec :: Text -> RowParser BI.Recurrence
prec "annually" = nullField *> pure BI.Annually
prec "monthly" = BI.Monthly <$> field
prec "semimonthly" = nullField *> pure BI.SemiMonthly
prec "weekly" = BI.Weekly <$> field
prec "onetime" = nullField *> pure BI.OneTime
prec _ = empty
in field >>= prec
case tn of
"event_t" ->
let err = UnexpectedNull { errSQLType = B.unpack tn
, errSQLTableOid = tableOid f
, errSQLField = maybe "" B.unpack (name f)
, errHaskellType = "UTCTime -> LogEvent"
, errMessage = "columns of type event_t should not contain null values"
}
in maybe (conversionError err) (nameEvent . decodeUtf8) v
_ ->
let err = Incompatible { errSQLType = B.unpack tn
, errSQLTableOid = tableOid f
, errSQLField = maybe "" B.unpack (name f)
, errHaskellType = "UTCTime -> LogEvent"
, errMessage = "column was not of type event_t"
}
in conversionError err
if tn /= "event_t"
then returnError Incompatible f "column was not of type event_t"
else maybe (returnError UnexpectedNull f "event type may not be null") (nameEvent . decodeUtf8) v
creditToParser f v = do
tn <- typename f
let parser :: Text -> Conversion (RowParser CreditTo)
parser tname = pure $ case tname of
"credit_to_btc_addr" -> CreditToAddress <$> (fieldWith btcAddrParser <* nullField <* nullField)
"credit_to_user" -> CreditToUser <$> (nullField *> fieldWith uidParser <* nullField)
"credit_to_project" -> CreditToProject <$> (nullField *> nullField *> fieldWith pidParser)
_ -> empty
creditToParser f v =
let parser :: Text -> RowParser CreditTo
parser "credit_to_btc_addr" = CreditToAddress <$> (fieldWith btcAddrParser <* nullField <* nullField)
parser "credit_to_user" = CreditToUser <$> (nullField *> fieldWith uidParser <* nullField)
parser "credit_to_project" = CreditToProject <$> (nullField *> nullField *> fieldWith pidParser)
parser _ = empty
in do
tn <- typename f
if tn /= "credit_to_t"
then returnError Incompatible f "column was not of type credit_to_t"
else maybe empty (pure . parser . decodeUtf8) v
case tn of
"credit_to_t" -> maybe empty (parser . decodeUtf8) v
_ -> conversionError $
Incompatible
(B.unpack tn)
(tableOid f)
(maybe "" B.unpack (name f))
"RowParser CreditTo"
"column was not of type event_t"
Auction <$> fieldWith pidParser
<*> fieldWith uidParser
<*> fieldWith utcParser
<*> fieldWith btcParser
<*> fieldWith utcParser
<*> fieldWith utcParser
A.Auction <$> fieldWith pidParser
<*> fieldWith uidParser
<*> fieldWith utcParser
<*> fieldWith btcParser
<*> fieldWith utcParser
<*> fieldWith utcParser
Bid <$> fieldWith uidParser
<*> fieldWith secondsParser
<*> fieldWith btcParser
<*> fieldWith utcParser
A.Bid <$> fieldWith uidParser
<*> fieldWith secondsParser
<*> fieldWith btcParser
<*> fieldWith utcParser
Project <$> field
<*> fieldWith utcParser
<*> fieldWith uidParser
<*> fieldWith fromJSONField
P.Project <$> field
<*> fieldWith utcParser
<*> fieldWith uidParser
<*> fieldWith fromJSONField
Invitation <$> fieldWith pidParser
<*> fieldWith uidParser
<*> fieldWith emailParser
<*> fieldWith utcParser
<*> fmap (fmap toThyme) field
P.Invitation <$> fieldWith pidParser
<*> fieldWith uidParser
<*> fieldWith emailParser
<*> fieldWith utcParser
<*> fmap (fmap toThyme) field
instance DBEval QDBM where
dbEval (CreateEvent (ProjectId pid) (UserId uid) (LogEntry c e m)) =
case c of
CreditToAddress addr ->
pinsert EventId
"INSERT INTO work_events \
\(project_id, user_id, credit_to_type, credit_to_btc_addr, event_type, event_time, event_metadata) \
\VALUES (?, ?, ?, ?, ?, ?, ?) \
\RETURNING id"
( pid, uid, creditToName c, addr ^. _BtcAddr . to addrToBase58, eventName e, fromThyme $ e ^. eventTime, m)
storeEvent :: DBOp a -> Maybe (QDBM EventId)
storeEvent (CreateBillable _) = error "Not implemented"
storeEvent (CreateSubscription _ _) = error "Not implemented"
storeEvent (CreatePaymentRequest _) = error "Not implemented"
storeEvent (CreatePayment _) = error "Not implemented"
storeEvent _ = Nothing
CreditToProject pid' ->
pinsert EventId
"INSERT INTO work_events \
\(project_id, user_id, credit_to_type, credit_to_project_id, event_type, event_time, event_metadata) \
\VALUES (?, ?, ?, ?, ?, ?, ?) \
\RETURNING id"
( pid, uid, creditToName c, pid' ^. _ProjectId, eventName e, fromThyme $ e ^. eventTime, m)
updateCache :: DBOp a -> QDBM a
updateCache (CreateEvent (P.ProjectId pid) (UserId uid) (LogEntry c e m)) =
case c of
CreditToAddress addr ->
pinsert EventId
"INSERT INTO work_events \
\(project_id, user_id, credit_to_type, credit_to_btc_addr, event_type, event_time, event_metadata) \
\VALUES (?, ?, ?, ?, ?, ?, ?) \
\RETURNING id"
( pid, uid, creditToName c, addr ^. _BtcAddr . to addrToBase58, eventName e, fromThyme $ e ^. eventTime, m)
CreditToUser uid' ->
pinsert EventId
"INSERT INTO work_events \
\(project_id, user_id, credit_to_type, credit_to_user_id, event_type, event_time, event_metadata) \
\VALUES (?, ?, ?, ?, ?, ?, ?) \
\RETURNING id"
( pid, uid, creditToName c, uid' ^. _UserId, eventName e, fromThyme $ e ^. eventTime, m)
CreditToProject pid' ->
pinsert EventId
"INSERT INTO work_events \
\(project_id, user_id, credit_to_type, credit_to_project_id, event_type, event_time, event_metadata) \
\VALUES (?, ?, ?, ?, ?, ?, ?) \
\RETURNING id"
( pid, uid, creditToName c, pid' ^. P._ProjectId, eventName e, fromThyme $ e ^. eventTime, m)
dbEval (FindEvent (EventId eid)) =
headMay <$> pquery qdbLogEntryParser
"SELECT project_id, user_id, \
\credit_to_type, credit_to_btc_addr, credit_to_user_id, credit_to_project_id, \
\event_type, event_time, event_metadata FROM work_events \
\WHERE id = ?"
(Only eid)
CreditToUser uid' ->
pinsert EventId
"INSERT INTO work_events \
\(project_id, user_id, credit_to_type, credit_to_user_id, event_type, event_time, event_metadata) \
\VALUES (?, ?, ?, ?, ?, ?, ?) \
\RETURNING id"
( pid, uid, creditToName c, uid' ^. _UserId, eventName e, fromThyme $ e ^. eventTime, m)
dbEval (FindEvents (ProjectId pid) (UserId uid) ival) =
let q (Before e) = pquery logEntryParser
"SELECT btc_addr, event_type, event_time, event_metadata FROM work_events \
\WHERE project_id = ? AND user_id = ? AND event_time <= ?"
(pid, uid, fromThyme e)
q (During s e) = pquery logEntryParser
"SELECT btc_addr, event_type, event_time, event_metadata FROM work_events \
\WHERE project_id = ? AND user_id = ? \
\AND event_time >= ? AND event_time <= ?"
(pid, uid, fromThyme s, fromThyme e)
q (After s) = pquery logEntryParser
"SELECT btc_addr, event_type, event_time, event_metadata FROM work_events \
\WHERE project_id = ? AND user_id = ? AND event_time >= ?"
(pid, uid, fromThyme s)
in q ival
updateCache (FindEvent (EventId eid)) =
headMay <$> pquery qdbLogEntryParser
"SELECT project_id, user_id, \
\credit_to_type, credit_to_btc_addr, credit_to_user_id, credit_to_project_id, \
\event_type, event_time, event_metadata FROM work_events \
\WHERE id = ?"
(Only eid)
dbEval (AmendEvent (EventId eid) (TimeChange mt t)) =
pinsert AmendmentId
"INSERT INTO event_time_amendments \
\(event_id, amended_at, event_time) \
\VALUES (?, ?, ?) RETURNING id"
( eid, fromThyme $ mt ^. _ModTime, fromThyme t )
updateCache (FindEvents (P.ProjectId pid) (UserId uid) ival) =
let q (Before e) = pquery logEntryParser
"SELECT btc_addr, event_type, event_time, event_metadata FROM work_events \
\WHERE project_id = ? AND user_id = ? AND event_time <= ?"
(pid, uid, fromThyme e)
q (During s e) = pquery logEntryParser
"SELECT btc_addr, event_type, event_time, event_metadata FROM work_events \
\WHERE project_id = ? AND user_id = ? \
\AND event_time >= ? AND event_time <= ?"
(pid, uid, fromThyme s, fromThyme e)
q (After s) = pquery logEntryParser
"SELECT btc_addr, event_type, event_time, event_metadata FROM work_events \
\WHERE project_id = ? AND user_id = ? AND event_time >= ?"
(pid, uid, fromThyme s)
in q ival
dbEval (AmendEvent (EventId eid) (CreditToChange mt c)) =
case c of
CreditToAddress addr ->
pinsert AmendmentId
"INSERT INTO event_credit_to_amendments \
\(event_id, amended_at, credit_to_type, credit_to_btc_addr) \
\VALUES (?, ?, ?, ?) RETURNING id"
( eid, fromThyme $ mt ^. _ModTime, creditToName c, addr ^. _BtcAddr . to addrToBase58 )
updateCache (AmendEvent (EventId eid) (TimeChange mt t)) =
pinsert AmendmentId
"INSERT INTO event_time_amendments \
\(event_id, amended_at, event_time) \
\VALUES (?, ?, ?) RETURNING id"
( eid, fromThyme $ mt ^. _ModTime, fromThyme t )
CreditToProject pid ->
pinsert AmendmentId
"INSERT INTO event_credit_to_amendments \
\(event_id, amended_at, credit_to_type, credit_to_project_id) \
\VALUES (?, ?, ?, ?) RETURNING id"
( eid, fromThyme $ mt ^. _ModTime, creditToName c, pid ^. _ProjectId )
updateCache (AmendEvent (EventId eid) (CreditToChange mt c)) =
case c of
CreditToAddress addr ->
pinsert AmendmentId
"INSERT INTO event_credit_to_amendments \
\(event_id, amended_at, credit_to_type, credit_to_btc_addr) \
\VALUES (?, ?, ?, ?) RETURNING id"
( eid, fromThyme $ mt ^. _ModTime, creditToName c, addr ^. _BtcAddr . to addrToBase58 )
CreditToUser uid ->
pinsert AmendmentId
"INSERT INTO event_credit_to_amendments \
\(event_id, amended_at, credit_to_type, credit_to_user_id) \
\VALUES (?, ?, ?, ?) RETURNING id"
( eid, fromThyme $ mt ^. _ModTime, creditToName c, uid ^. _UserId )
CreditToProject pid ->
pinsert AmendmentId
"INSERT INTO event_credit_to_amendments \
\(event_id, amended_at, credit_to_type, credit_to_project_id) \
\VALUES (?, ?, ?, ?) RETURNING id"
( eid, fromThyme $ mt ^. _ModTime, creditToName c, pid ^. P._ProjectId )
dbEval (AmendEvent (EventId eid) (MetadataChange mt v)) =
pinsert AmendmentId
"INSERT INTO event_metadata_amendments \
\(event_id, amended_at, event_metadata) \
\VALUES (?, ?, ?) RETURNING id"
( eid, fromThyme $ mt ^. _ModTime, v)
CreditToUser uid ->
pinsert AmendmentId
"INSERT INTO event_credit_to_amendments \
\(event_id, amended_at, credit_to_type, credit_to_user_id) \
\VALUES (?, ?, ?, ?) RETURNING id"
( eid, fromThyme $ mt ^. _ModTime, creditToName c, uid ^. _UserId )
dbEval (ReadWorkIndex (ProjectId pid)) = do
logEntries <- pquery logEntryParser
"SELECT btc_addr, event_type, event_time, event_metadata FROM work_events WHERE project_id = ?"
(Only pid)
pure $ workIndex logEntries
updateCache (AmendEvent (EventId eid) (MetadataChange mt v)) =
pinsert AmendmentId
"INSERT INTO event_metadata_amendments \
\(event_id, amended_at, event_metadata) \
\VALUES (?, ?, ?) RETURNING id"
( eid, fromThyme $ mt ^. _ModTime, v)
dbEval (CreateAuction auc) =
pinsert AuctionId
"INSERT INTO auctions (project_id, user_id, raise_amount, end_time) \
\VALUES (?, ?, ?, ?) RETURNING id"
( auc ^. (A.projectId . _ProjectId)
, auc ^. (A.initiator . _UserId)
, auc ^. (raiseAmount . satoshi)
, auc ^. (auctionEnd.to fromThyme)
)
updateCache (ReadWorkIndex (P.ProjectId pid)) = do
logEntries <- pquery logEntryParser
"SELECT btc_addr, event_type, event_time, event_metadata FROM work_events WHERE project_id = ?"
(Only pid)
pure $ workIndex logEntries
dbEval (FindAuction aucId) =
headMay <$> pquery auctionParser
"SELECT project_id, initiator_id, created_at, raise_amount, start_time, end_time FROM auctions WHERE id = ?"
(Only (aucId ^. _AuctionId))
updateCache (CreateAuction auc) =
pinsert A.AuctionId
"INSERT INTO auctions (project_id, user_id, raise_amount, end_time) \
\VALUES (?, ?, ?, ?) RETURNING id"
( auc ^. (A.projectId . P._ProjectId)
, auc ^. (A.initiator . _UserId)
, auc ^. (A.raiseAmount . satoshi)
, auc ^. (A.auctionEnd . to fromThyme)
)
dbEval (CreateBid (AuctionId aucId) bid) =
pinsert BidId
"INSERT INTO bids (auction_id, bidder_id, bid_seconds, bid_amount, bid_time) \
\VALUES (?, ?, ?, ?, ?) RETURNING id"
( aucId
, bid ^. (bidUser._UserId)
, case bid ^. bidSeconds of (Seconds i) -> i
, bid ^. (bidAmount . satoshi)
, bid ^. (bidTime.to fromThyme)
)
updateCache (FindAuction aucId) =
headMay <$> pquery auctionParser
"SELECT project_id, initiator_id, created_at, raise_amount, start_time, end_time FROM auctions WHERE id = ?"
(Only (aucId ^. A._AuctionId))
dbEval (ReadBids aucId) =
pquery bidParser
"SELECT user_id, bid_seconds, bid_amount, bid_time FROM bids WHERE auction_id = ?"
(Only (aucId ^. _AuctionId))
updateCache (CreateBid (A.AuctionId aucId) bid) =
pinsert A.BidId
"INSERT INTO bids (auction_id, bidder_id, bid_seconds, bid_amount, bid_time) \
\VALUES (?, ?, ?, ?, ?) RETURNING id"
( aucId
, bid ^. (A.bidUser . _UserId)
, case bid ^. A.bidSeconds of (Seconds i) -> i
, bid ^. (A.bidAmount . satoshi)
, bid ^. (A.bidTime . to fromThyme)
)
dbEval (CreateUser user') =
let addrMay :: Maybe ByteString
addrMay = user' ^? (userAddress . traverse . _BtcAddr . to addrToBase58)
in pinsert UserId
"INSERT INTO users (handle, btc_addr, email) VALUES (?, ?, ?) RETURNING id"
( user' ^. (username._UserName)
, addrMay
, user' ^. userEmail._Email
)
updateCache (ReadBids aucId) =
pquery bidParser
"SELECT user_id, bid_seconds, bid_amount, bid_time FROM bids WHERE auction_id = ?"
(Only (aucId ^. A._AuctionId))
dbEval (FindUser (UserId uid)) =
headMay <$> pquery userParser
"SELECT handle, btc_addr, email FROM users WHERE id = ?"
(Only uid)
updateCache (CreateUser user') =
let addrMay :: Maybe ByteString
addrMay = user' ^? (userAddress . traverse . _BtcAddr . to addrToBase58)
in pinsert UserId
"INSERT INTO users (handle, btc_addr, email) VALUES (?, ?, ?) RETURNING id"
( user' ^. (username._UserName)
, addrMay
, user' ^. userEmail._Email
)
dbEval (FindUserByName (UserName h)) =
headMay <$> pquery qdbUserParser
"SELECT id, handle, btc_addr, email FROM users WHERE handle = ?"
(Only h)
updateCache (FindUser (UserId uid)) =
headMay <$> pquery userParser
"SELECT handle, btc_addr, email FROM users WHERE id = ?"
(Only uid)
dbEval (CreateInvitation (ProjectId pid) (UserId uid) (Email e) t) = do
invCode <- liftIO randomInvCode
void $ pexec
"INSERT INTO invitations (project_id, invitor_id, invitee_email, invitation_key, invitation_time) \
\VALUES (?, ?, ?, ?, ?)"
(pid, uid, e, renderInvCode invCode, fromThyme t)
pure invCode
updateCache (FindUserByName (UserName h)) =
headMay <$> pquery qdbUserParser
"SELECT id, handle, btc_addr, email FROM users WHERE handle = ?"
(Only h)
updateCache (CreateInvitation (P.ProjectId pid) (UserId uid) (Email e) t) = do
invCode <- liftIO P.randomInvCode
void $ pexec
"INSERT INTO invitations (project_id, invitor_id, invitee_email, invitation_key, invitation_time) \
\VALUES (?, ?, ?, ?, ?)"
(pid, uid, e, P.renderInvCode invCode, fromThyme t)
pure invCode
updateCache (FindInvitation ic) =
headMay <$> pquery invitationParser
"SELECT project_id, invitor_id, invitee_email, invitation_time, acceptance_time \
\FROM invitations WHERE invitation_key = ?"
(Only $ P.renderInvCode ic)
dbEval (FindInvitation ic) =
headMay <$> pquery invitationParser
"SELECT project_id, invitor_id, invitee_email, invitation_time, acceptance_time \
\FROM invitations WHERE invitation_key = ?"
(Only $ renderInvCode ic)
updateCache (AcceptInvitation (UserId uid) ic t) = transactQDBM $ do
void $ pexec
"UPDATE invitations SET acceptance_time = ? WHERE invitation_key = ?"
(fromThyme t, P.renderInvCode ic)
void $ pexec
"INSERT INTO project_companions (project_id, user_id, invited_by, joined_at) \
\SELECT i.project_id, ?, i.invitor_id, ? \
\FROM invitations i \
\WHERE i.invitation_key = ?"
(uid, fromThyme t, P.renderInvCode ic)
dbEval (AcceptInvitation (UserId uid) ic t) = transactQDBM $ do
void $ pexec
"UPDATE invitations SET acceptance_time = ? WHERE invitation_key = ?"
(fromThyme t, renderInvCode ic)
void $ pexec
"INSERT INTO project_companions (project_id, user_id, invited_by, joined_at) \
\SELECT i.project_id, ?, i.invitor_id, ? \
\FROM invitations i \
\WHERE i.invitation_key = ?"
(uid, fromThyme t, renderInvCode ic)
updateCache (CreateProject p) =
pinsert P.ProjectId
"INSERT INTO projects (project_name, inception_date, initiator_id, depreciation_fn) \
\VALUES (?, ?, ?, ?) RETURNING id"
(p ^. P.projectName, p ^. (P.inceptionDate . to fromThyme), p ^. (P.initiator . _UserId), toJSON $ p ^. P.depf)
dbEval (CreateProject p) =
pinsert ProjectId
"INSERT INTO projects (project_name, inception_date, initiator_id, depreciation_fn) \
\VALUES (?, ?, ?, ?) RETURNING id"
(p ^. projectName, p ^. (inceptionDate.to fromThyme), p ^. (P.initiator . _UserId), toJSON $ p ^. depf)
updateCache (FindProject (P.ProjectId pid)) =
headMay <$> pquery projectParser
"SELECT project_name, inception_date, initiator_id, depreciation_fn FROM projects WHERE id = ?"
(Only pid)
dbEval (FindProject (ProjectId pid)) =
headMay <$> pquery projectParser
"SELECT project_name, inception_date, initiator_id, depreciation_fn FROM projects WHERE id = ?"
(Only pid)
updateCache (FindUserProjects (UserId uid)) =
pquery qdbProjectParser
"SELECT p.id, p.project_name, p.inception_date, p.initiator_id, p.depreciation_fn \
\FROM projects p LEFT OUTER JOIN project_companions pc ON pc.project_id = p.id \
\WHERE pc.user_id = ? \
\OR p.initiator_id = ?"
(uid, uid)
dbEval (FindUserProjects (UserId uid)) =
pquery qdbProjectParser
"SELECT p.id, p.project_name, p.inception_date, p.initiator_id, p.depreciation_fn \
\FROM projects p LEFT OUTER JOIN project_companions pc ON pc.project_id = p.id \
\WHERE pc.user_id = ? \
\OR p.initiator_id = ?"
(uid, uid)
updateCache (AddUserToProject pid current new) = void $
pexec
"INSERT INTO project_companions (project_id, user_id, invited_by) VALUES (?, ?, ?)"
(pid ^. P._ProjectId, new ^. _UserId, current ^. _UserId)
dbEval (AddUserToProject pid current new) = void $
pexec
"INSERT INTO project_companions (project_id, user_id, invited_by) VALUES (?, ?, ?)"
(pid ^. _ProjectId, new ^. _UserId, current ^. _UserId)
updateCache dbop @ (CreateBillable b) = do
eventId <- requireEventId dbop
pinsert BI.BillableId
"INSERT INTO billables \
\(project_id, event_id, name, description, recurrence_type, recurrence_count, billing_amount, grace_period_days)\
\VALUES (?, ?, ?, ?, ?, ?, ?, ?) RETURNING id"
( b ^. (BI.project . P._ProjectId)
, eventId ^. _EventId
, b ^. BI.name
, b ^. BI.description
, b ^. (BI.recurrence . to BI.recurrenceName)
, b ^. (BI.recurrence . to BI.recurrenceCount)
, b ^. (BI.amount . satoshi)
, b ^. (BI.gracePeriod . _Days)
)
dbEval (CreateBillable _) = error "Not implemented"
dbEval (ReadBillable _) = error "Not implemented"
dbEval (CreatePaymentRequest _ _) = error "Not implemented"
dbEval (CreatePayment _ ) = error "Not implemented"
updateCache (ReadBillable bid) =
headMay <$> pquery billableParser
"SELECT b.project_id, e.created_by, b.name, b.description, b.recurrence_type, b.recurrence_count, \
\ b.billing_amount, b.grace_period_days \
\FROM billables b JOIN aftok_events e ON e.id = b.event_id \
\WHERE b.id = ?"
(Only (bid ^. BI._BillableId))
instance DBEval QDBM where
dbEval e = updateCache e
CreateBillable :: Billable ProjectId Satoshi -> DBOp BillableId
ReadBillable :: BillableId -> DBOp (Maybe (Billable ProjectId Satoshi))
CreateBillable :: Billable -> DBOp BillableId
ReadBillable :: BillableId -> DBOp (Maybe Billable)
CreateSubscription :: UserId -> BillableId -> DBOp SubscriptionId
CreatePaymentRequest :: UserId -> PaymentRequest ProjectId BillableId -> DBOp PaymentRequestId
CreatePayment :: Payment PaymentRequestId UserId -> DBOp PaymentId
CreatePaymentRequest :: PaymentRequest SubscriptionId -> DBOp PaymentRequestId
CreatePayment :: Payment PaymentRequestId -> DBOp PaymentId
createBillable :: UserId -> Billable ProjectId Satoshi -> DBProg BillableId
createBillable uid b = withProjectAuth (b ^. B.project) uid $ CreateBillable b
createBillable :: Billable -> DBProg BillableId
createBillable b = withProjectAuth (b ^. B.project) (b ^. B.creator) $ CreateBillable b