Types.hs

Types.hs

{-# LANGUAGE Arrows #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE StandaloneDeriving #-}

module Haven.Types where

import           Haven.TH

import           Control.Lens
import           Opaleye
import           Data.Int (Int64)
import           Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import           Data.Time.Clock (getCurrentTime, UTCTime)
import qualified Database.PostgreSQL.Simple                          as PGS

data UserId' a    = UserId a
type UserId       = UserId' Int
type UserIdColumn = UserId' (Column PGInt4)
$(makeAdaptorAndInstance "pUserId" ''UserId')

data User' a b c d e f = User { _uId        :: a
                              , _uFirstName :: b
                              , _uLastName  :: c
                              , _uEmail     :: d
                              , _uUsername  :: e
                              , _uPassword  :: f }

type User        = User' UserId String String String String String

type UserColumn  = User' UserIdColumn
                         (Column PGText)
                         (Column PGText)
                         (Column PGText)
                         (Column PGText)
                         (Column PGText)

$(makeAdaptorAndInstance "pUser" ''User')
makeClassy ''User'

userTable :: Table UserColumn UserColumn
userTable = Table "user_table"
                  (pUser User { _uId        = pUserId (UserId (required "id"))
                              , _uFirstName = required "first_name"
                              , _uLastName  = required "last_name"
                              , _uEmail     = required "email"
                              , _uUsername  = required "username"
                              , _uPassword  = required "password"})


data TicketId' a    = TicketId a deriving (Functor)

unTicketId :: TicketId' a -> a
unTicketId (TicketId x) = x

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)

$(makeLensesWith (namedClassyRules "HasTicket" "ticket") ''Ticket')

type Ticket = Ticket' TicketId String UserId UTCTime UTCTime

type TicketColumn = Ticket' TicketIdColumn
                            (Column PGText)
                            UserIdColumn
                            (Column PGTimestamptz)
                            (Column PGTimestamptz)

$(makeAdaptorAndInstance "pTicket" ''Ticket')

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

   condExpr :: TicketId -> TicketColumn -> Column PGBool
   condExpr tid col  = unTicketId (col ^. tId) .== (pgInt4 . unTicketId $ tid)