further modernisation

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
       )