Types.hs

Types.hs

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

module Haven.Types where

import           Control.Lens
import           Opaleye
import           Data.Int (Int64)
import           Data.Functor
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)
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)