Types.hs

gistfile1.hs

data TicketId' a    = TicketId a deriving (Functor)
type TicketId       = TicketId' Int
type TicketIdColumn = TicketId' (Column PGInt4)
$(makeAdaptorAndInstance "pTicketId" ''TicketId')

data Ticket' a b c d e = Ticket { _tId       :: a
                                , _tTicket   :: b
                                , _tUserId   :: c
                                , _tExpires  :: d
                                , _tConsumed :: e }
                                deriving (Show)
type Ticket            = Ticket' TicketId String UserId UTCTime UTCTime
type TicketColumn      = Ticket' TicketIdColumn
                                 (Column PGText)
                                 UserIdColumn
                                 (Column PGTimestamptz)
                                 (Column PGTimestamptz)
$(makeAdaptorAndInstance "pTicket" ''Ticket')
makeClassy ''Ticket'

instance HasTicket' TicketColumn where ticket' = id

ticketTable :: Table TicketColumn TicketColumn
ticketTable = Table "ticket_table"
                    (pTicket Ticket { _tId       = pTicketId (TicketId (required "id"))
                                    , _tTicket   = required "ticket"
                                    , _tUserId   = pUserId (UserId (required "user_id"))
                                    , _tExpires  = required "expiration_date"
                                    , _tConsumed = required "consumed" })

consumeTicket' :: PGS.Connection -> Ticket -> IO Int64
consumeTicket' conn t = do
  now <- getCurrentTime
  runUpdate conn ticketTable (updateExpr now) (condExpr (t ^. tId))
 where
   updateExpr :: UTCTime -> (TicketColumn -> TicketColumn)
  -- updateExpr now = tConsumed .~ (pgUTCTime now)
   updateExpr now = tConsumed .~ (pgUTCTime now)

   condExpr :: TicketId -> (TicketColumn -> Column PGBool)
   condExpr (TicketId id) c = (c ^. tId) .== (pgInt4 id)