mateamt/src/Model/User.hs

{-# LANGUAGE OverloadedStrings #-}
module Model.User where

import Data.Text as T hiding (head, foldl)
import Data.Time.Calendar
import Data.Time.Clock

import Data.Profunctor.Product (p6)

import Data.Int (Int64)

import qualified Database.PostgreSQL.Simple as PGS

import Control.Arrow ((<<<))

import Control.Monad.IO.Class (liftIO)

import Opaleye as O
import qualified Opaleye.Constant as C

-- internal imports

import Types.User
import Types.Refine
import Types.Reader

initUser :: PGS.Query
initUser = mconcat
  [ "CREATE TABLE IF NOT EXISTS \"user\" ("
  , "user_id        SERIAL PRIMARY KEY,"
  , "user_ident     TEXT NOT NULL,"
  , "user_balance   INTEGER NOT NULL,"
  , "user_timestamp DATE NOT NULL,"
  , "user_email     TEXT,"
  , "user_avatar    INTEGER REFERENCES \"avatar\"(\"avatar_id\") ON DELETE CASCADE"
  , ")"
  ]

userTable :: Table
  ( Maybe (Field SqlInt4)
  , Field SqlText
  , Field SqlInt4
  , Field SqlDate
  , FieldNullable SqlText
  , FieldNullable SqlInt4
  )
  ( Field SqlInt4
  , Field SqlText
  , Field SqlInt4
  , Field SqlDate
  , FieldNullable SqlText
  , FieldNullable SqlInt4
  )
userTable = table "user" (
  p6
    ( tableField "user_id"
    , tableField "user_ident"
    , tableField "user_balance"
    , tableField "user_timestamp"
    , tableField "user_email"
    , tableField "user_avatar"
    )
  )

userSelect
  :: UserRefine
  -> PGS.Connection
  -> MateHandler [UserSummary]
userSelect ref conn = do
  today <- utctDay <$> liftIO getCurrentTime
  users <- liftIO $ runSelect conn (case ref of
      AllUsers -> selectTable userTable
      ActiveUsers -> keepWhen (\(_, _, _, ts, _, _) ->
        ts .>= C.constant (addDays (-30) today)
        ) <<< queryTable userTable
      OldUsers -> keepWhen (\(_, _, _, ts, _, _) ->
        ts .<= C.constant (addDays (-30) today)
        ) <<< queryTable userTable
      ) :: MateHandler
          [ ( Int
            , Text
            , Int
            , Day
            , Maybe Text
            , Maybe Int
            )
          ]
  mapM
    (\(i1, i2, _, _, _, i6) -> return $
      UserSummary i1 i2 i6
      )
    users

userDetailsSelect
  :: Int
  -> PGS.Connection
  -> MateHandler UserDetails
userDetailsSelect uid conn = do
  users <- liftIO $ runSelect conn (
      keepWhen (\(uuid, _, _, _, _, _) ->
        uuid .== C.constant uid
        ) <<< queryTable userTable
      ) :: MateHandler
          [ ( Int
            , Text
            , Int
            , Day
            , Maybe Text
            , Maybe Int
            )
          ]
  head <$> mapM
    (\(i1, i2, i3, _, i5, i6) -> return $
      UserDetails i1 i2 i3 i5 i6
      )
    users


userBalanceSelect
  :: PGS.Connection
  -> Int
  -> MateHandler Int
userBalanceSelect conn uid = do
  users <- liftIO $ runSelect conn (
      keepWhen (\(uuid, _, _, _, _, _) ->
        uuid .== C.constant uid
        ) <<< queryTable userTable
      ) :: MateHandler
          [ ( Int
            , Text
            , Int
            , Day
            , Maybe Text
            , Maybe Int
            )
          ]
  head <$> mapM
    (\(_, _, i3, _, _, _) -> return i3)
    users


insertUser
  :: T.Text
  -> Maybe T.Text
  -> Day
  -> PGS.Connection
  -> MateHandler Int
insertUser ident email now conn = fmap head $ liftIO $ runInsert_ conn $ Insert
  { iTable = userTable
  , iRows  =
    [
    ( C.constant (Nothing :: Maybe Int)
    , C.constant ident
    , C.constant (0 :: Int)
    , C.constant now
    , C.constant email
    , C.constant (Nothing :: Maybe Int)
    )
    ]
  , iReturning = rReturning (\(uid, _, _, _, _, _) -> uid)
  , iOnConflict = Nothing
  }

updateUserDetails
  :: Int
  -> UserDetailsSubmit
  -> Day
  -> PGS.Connection
  -> MateHandler Int64
updateUserDetails uid uds now conn = liftIO $ runUpdate_ conn $ Update
  { uTable      = userTable
  , uUpdateWith = updateEasy (\(id_, _, i3, _, _, _) ->
      ( id_
      , C.constant (userDetailsSubmitIdent uds)
      , i3
      , C.constant now
      , C.constant (userDetailsSubmitEmail uds)
      , C.constant (userDetailsSubmitAvatar uds)
      )
    )
  , uWhere      = \(i1, _, _, _, _, _) -> i1 .== C.constant uid
  , uReturning  = rCount
  }

addToUserBalance
  :: Int
  -> Int
  -> PGS.Connection
  -> MateHandler Int64
addToUserBalance uid amount conn = liftIO $ runUpdate_ conn $ Update
  { uTable      = userTable
  , uUpdateWith = updateEasy (\(id_, i2, i3, i4, i5, i6) ->
      ( id_
      , i2
      , i3 + C.constant amount
      , i4
      , i5
      , i6
      )
    )
  , uWhere      = \(i1, _, _, _, _, _) -> i1 .== C.constant uid
  , uReturning  = rCount
  }