more instances of ToDatabase and FromDatabase

src/Model/Product.hs

@@ -6,10 +6,13 @@ module Model.Product where
 
 import Data.Text (Text)
 import qualified Data.Text as T hiding (head, foldl, map)
+
 import Data.Time (getCurrentTime)
-import Data.Time.Clock (UTCTime)
+
 import Data.Profunctor.Product (p9)
 
+import Data.Maybe
+
 import Control.Monad.IO.Class (liftIO)
 
 import Control.Arrow
@@ -83,37 +86,23 @@ productSelect
   -> MateHandler [Product]
 productSelect conn = do
   liftIO $ map fromDatabase <$> runSelect conn
-    ( keepWhen (\_ -> C.constant True) <<< queryTable productTable
-    )
+    (queryTable productTable)
 
 
 productSelectSingle
   :: Int
   -> PGS.Connection
-  -> MateHandler [Product]
+  -> MateHandler (Maybe Product)
 productSelectSingle pid conn = do
-  prods <- liftIO $ runSelect conn
+  prods <- liftIO $ map fromDatabase <$> runSelect conn
     ( limit 1
       (keepWhen (
         \(id_, _, _, _, _, _, _, _, _) -> id_ .== C.constant pid
         ) <<< queryTable productTable)
-    ) :: MateHandler
-        [ ( Int
-          , T.Text
-          , Int
-          , Maybe Int
-          , Maybe Int
-          , Int
-          , Int
-          , Maybe Int
-          , Maybe T.Text
-          )
-        ]
-  mapM
-    (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> return $
-      Product i1 i2 i3 i4 i5 i6 i7 i8 i9
-      )
-    prods
+    )
+  case prods of
+    p:_ -> return (Just p)
+    _    -> return Nothing
 
 
 productOverviewSelect
@@ -193,12 +182,13 @@ produceProductOverviews refine =
 queryAmounts
   :: PGS.Connection
   -> Int
-  -> IO [(Int, UTCTime, Int, Int, Bool)]
-queryAmounts conn pid = runSelect conn $ proc () -> do
+  -> IO [Amount]
+queryAmounts conn pid = map fromDatabase <$> runSelect conn (proc () -> do
   stuff@(a1, _, _, _, _) <- orderBy (desc (\(_, ts, _, _, _) -> ts))
     (queryTable amountTable) -< ()
   restrict -< C.constant pid .== a1
   returnA -< stuff
+  )
 
 generateProductOverview
   :: PGS.Connection
@@ -219,14 +209,14 @@ generateProductOverview conn (i1, i2, i3, i4, i5, i6, i7, i8, i9, a3, a4) = do
   amounts <- liftIO $ queryAmounts conn i1
   let ii5 = snd $
         foldl
-          (\(bef, van) (_, _, amo, _, ver) ->
+          (\(bef, van) (Amount _ _ amo _ ver) ->
             if ver
             then (amo, if amo < bef then van + (bef - amo) else van)
             else (amo, van)
             )
           (0, 0)
-          (Prelude.reverse amounts)
-      ii10 = snd $ foldl (\(bef, tot) (_, _, amo, _, ver) ->
+          (reverse amounts)
+      ii10 = snd $ foldl (\(bef, tot) (Amount _ _ amo _ ver) ->
         if ver
         then (amo, tot)
         else (amo, tot + Prelude.max 0 (bef - amo))
@@ -307,7 +297,7 @@ manualProductAmountRefill aups conn =
     (\(AmountRefill pid amountSingles amountCrates) -> do
       oldamount <- getLatestAmountByProductId pid conn
       oldprice <- getLatestPriceByProductId pid conn
-      perCrate <- productAmountPerCrate . head <$>
+      perCrate <- productAmountPerCrate . fromJust <$>
         productSelectSingle pid conn
       head <$> liftIO (do
         now <- getCurrentTime

src/Model/User.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Model.User where
 
-import Data.Text as T hiding (head, foldl)
+import qualified Data.Text as T
 import Data.Time.Calendar
 import Data.Time.Clock
 
@@ -23,6 +23,7 @@ import qualified Opaleye.Constant as C
 import Types.User
 import Types.Refine
 import Types.Reader
+import Classes
 
 initUser :: PGS.Query
 initUser = mconcat
@@ -68,7 +69,7 @@ userSelect
   -> MateHandler [UserSummary]
 userSelect ref conn = do
   today <- utctDay <$> liftIO getCurrentTime
-  users <- liftIO $ runSelect conn (
+  users <- liftIO $ map fromDatabase <$> runSelect conn (
     orderBy (asc (\(_, ident, _, _, _, _) -> ident)) (
       keepWhen (\(_, _, _, ts, _, _) -> case ref of
         AllUsers ->
@@ -78,17 +79,9 @@ userSelect ref conn = do
         OldUsers ->
           ts .< C.constant (addDays (-30) today)
         ) <<< selectTable userTable)
-        ) :: MateHandler
-            [ ( Int
-              , Text
-              , Int
-              , Day
-              , Maybe Text
-              , Maybe Int
-              )
-            ]
+        ) :: MateHandler [User]
   mapM
-    (\(i1, i2, _, _, _, i6) -> return $
+    (\(User i1 i2 _ _ _ i6) -> return $
       UserSummary i1 i2 i6
       )
     users
@@ -98,21 +91,13 @@ userDetailsSelect
   -> PGS.Connection
   -> MateHandler UserDetails
 userDetailsSelect uid conn = do
-  users <- liftIO $ runSelect conn (
+  users <- liftIO $ map fromDatabase <$> runSelect conn (
       keepWhen (\(uuid, _, _, _, _, _) ->
         uuid .== C.constant uid
         ) <<< queryTable userTable
-      ) :: MateHandler
-          [ ( Int
-            , Text
-            , Int
-            , Day
-            , Maybe Text
-            , Maybe Int
-            )
-          ]
+      ) :: MateHandler [User]
   head <$> mapM
-    (\(i1, i2, i3, _, i5, i6) -> return $
+    (\(User i1 i2 i3 _ i5 i6) -> return $
       UserDetails i1 i2 i3 i5 i6
       )
     users
@@ -123,22 +108,11 @@ userBalanceSelect
   -> Int
   -> MateHandler Int
 userBalanceSelect conn uid = do
-  users <- liftIO $ runSelect conn (
+  liftIO $ userBalance . fromDatabase . head <$> 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

src/Types/User.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeFamilies #-}
 module Types.User where
 
 import GHC.Generics
@@ -11,6 +12,8 @@ import qualified Data.Text as T
 
 -- internal imports
 
+import Classes
+
 data User
   = User
     { userId        :: Int
@@ -25,6 +28,20 @@ data User
     }
   deriving (Generic, Show)
 
+instance ToDatabase User where
+
+  type InTuple User = (Int, T.Text, Int, Day, Maybe T.Text, Maybe Int)
+
+  toDatabase (User id_ ident bal ts email ava) =
+    (id_, ident, bal, ts, email, ava)
+
+instance FromDatabase User where
+
+  type OutTuple User = (Int, T.Text, Int, Day, Maybe T.Text, Maybe Int)
+
+  fromDatabase  (id_, ident, bal, ts, email, ava) =
+    (User id_ ident bal ts email ava)
+
 
 data UserSummary = UserSummary
   { userSummaryId     :: Int