diff --git a/src/Model/User.hs b/src/Model/User.hs index de377a7..89f55b0 100644 --- a/src/Model/User.hs +++ b/src/Model/User.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Arrows #-} module Model.User where import qualified Data.Text as T @@ -11,7 +12,7 @@ import Data.Int (Int64) import qualified Database.PostgreSQL.Simple as PGS -import Control.Arrow ((<<<)) +import Control.Arrow import Control.Monad.IO.Class (liftIO) @@ -68,17 +69,18 @@ userSelect -> MateHandler [UserSummary] userSelect ref conn = do today <- utctDay <$> liftIO getCurrentTime - users <- liftIO $ map fromDatabase <$> runSelect conn ( - orderBy (asc (\(_, ident, _, _, _, _) -> ident)) ( - keepWhen (\(_, _, _, ts, _, _) -> case ref of + users <- liftIO $ map fromDatabase <$> runSelect conn ( proc () -> do + stuff@(_, _, _, ts, _, _) <- orderBy (asc (\(_, ident, _, _, _, _) -> ident)) + (selectTable userTable) -< () + restrict -< case ref of AllUsers -> toFields True ActiveUsers -> ts .>= toFields (addDays (-30) today) OldUsers -> ts .< toFields (addDays (-30) today) - ) <<< selectTable userTable) - ) :: MateHandler [User] + returnA -< stuff + ) :: MateHandler [User] mapM (\(User i1 i2 _ _ _ i6) -> return $ UserSummary i1 i2 i6 @@ -102,11 +104,11 @@ userDetailsSelect -> PGS.Connection -> MateHandler UserDetails userDetailsSelect uid conn = do - users <- liftIO $ map fromDatabase <$> runSelect conn (limit 1 $ - keepWhen (\(uuid, _, _, _, _, _) -> - uuid .== toFields uid - ) <<< selectTable userTable - ) :: MateHandler [User] + users <- liftIO $ map fromDatabase <$> runSelect conn (proc () -> do + stuff@(uuid, _, _, _, _, _) <- limit 1 (selectTable userTable) -< () + restrict -< uuid .== toFields uid + returnA -< stuff + ) :: MateHandler [User] head <$> mapM (\(User i1 i2 i3 _ i5 i6) -> return $ UserDetails i1 i2 i3 i5 i6 @@ -119,10 +121,10 @@ userBalanceSelect -> Int -> MateHandler Int userBalanceSelect conn uid = do - liftIO $ userBalance . fromDatabase . head <$> runSelect conn ( - keepWhen (\(uuid, _, _, _, _, _) -> - uuid .== toFields uid - ) <<< selectTable userTable + liftIO $ userBalance . fromDatabase . head <$> runSelect conn (proc () -> do + stuff@(uuid, _, _, _, _, _) <- selectTable userTable -< () + restrict -< uuid .== toFields uid + returnA -< stuff ) @@ -132,14 +134,14 @@ insertUser -> Day -> PGS.Connection -> MateHandler Int -insertUser ident email now conn = fmap head $ liftIO $ runInsert_ conn $ Insert +insertUser ident email now_ conn = fmap head $ liftIO $ runInsert_ conn $ Insert { iTable = userTable , iRows = [ ( toFields (Nothing :: Maybe Int) , toFields ident , toFields (0 :: Int) - , toFields now + , toFields now_ , toFields email , toFields (Nothing :: Maybe Int) ) @@ -154,13 +156,13 @@ updateUserDetails -> Day -> PGS.Connection -> MateHandler Int64 -updateUserDetails uid uds now conn = liftIO $ runUpdate_ conn $ Update +updateUserDetails uid uds now_ conn = liftIO $ runUpdate_ conn $ Update { uTable = userTable , uUpdateWith = updateEasy (\(id_, _, i3, _, _, _) -> ( id_ , toFields (userDetailsSubmitIdent uds) , i3 - , toFields now + , toFields now_ , toFields (userDetailsSubmitEmail uds) , toFields (userDetailsSubmitAvatar uds) ) @@ -174,13 +176,13 @@ updateUserTimestamp -> Day -> PGS.Connection -> MateHandler Int64 -updateUserTimestamp uid now conn = liftIO $ runUpdate_ conn $ Update +updateUserTimestamp uid now_ conn = liftIO $ runUpdate_ conn $ Update { uTable = userTable , uUpdateWith = updateEasy (\(id_, ident, balance, _, email, ava) -> ( id_ , ident , balance - , toFields now + , toFields now_ , email , ava )