make more instances of ToDatabase and FromDatabase

src/Model/Amount.hs

@@ -18,6 +18,7 @@ import Opaleye.Constant as C
 -- internal imports
 
 import Types
+import Classes
 
 initAmount :: PGS.Query
 initAmount = mconcat
@@ -82,40 +83,21 @@ getLatestPriceByProductId
   -> PGS.Connection
   -> MateHandler Int -- The price in cents
 getLatestPriceByProductId pid conn = do
-  amounts <- liftIO $ runSelect conn $
+  liftIO $ amountPrice . fromDatabase . head <$> runSelect conn (
     limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts))
-      (keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<< queryTable amountTable)
+      (keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid)
-    :: MateHandler
+        <<< queryTable amountTable)
-      [ ( Int
-        , UTCTime
-        , Int
-        , Int
-        , Bool
     )
-      ]
-  head <$> mapM
-    (\(_, _, _, price, _) -> return price)
-    amounts
 
 getLatestAmountByProductId
   :: Int             -- The associated Product ID
   -> PGS.Connection
   -> MateHandler Int -- The amount
 getLatestAmountByProductId pid conn = do
-  amounts <- liftIO $ runSelect conn $
+  liftIO $ amountAmount . fromDatabase . head <$> runSelect conn (
     limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts))
-      (keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<< queryTable amountTable)
+      (keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid)
-    :: MateHandler
+        <<< queryTable amountTable)
-      [ ( Int
-        , UTCTime
-        , Int
-        , Int
-        , Bool
-        )
-      ]
-  return (head $ map
-    (\(_, _, amount, _, _) -> amount)
-    amounts
     )
 
 getLatestTotalPrice
@@ -123,21 +105,11 @@ getLatestTotalPrice
   -> PGS.Connection
   -> MateHandler Int -- The price in cents
 getLatestTotalPrice (PurchaseDetail pid amount) conn = do
-  amounts <- liftIO $ runSelect conn $
+  liftIO $ (amount *) . amountPrice . fromDatabase . head <$>
+    runSelect conn (
       limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts)) $
         keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<<
           queryTable amountTable
-    :: MateHandler
-      [ ( Int
-        , UTCTime
-        , Int
-        , Int
-        , Bool
-        )
-      ]
-  return $ ((amount *) . head) (map
-    (\(_, _, _, price, _) -> price)
-    amounts
       )
 
 checkProductAvailability
@@ -145,19 +117,11 @@ checkProductAvailability
   -> PGS.Connection
   -> MateHandler (Maybe Int) -- ^ Returns maybe missing amount
 checkProductAvailability (PurchaseDetail pid amount) conn = do
-  realamount <- (\(_, _, ramount, _, _) -> ramount) . head <$>
+  realamount <- amountAmount . fromDatabase . head <$>
     (liftIO $ runSelect conn $ limit 1 $
       orderBy (desc (\(_, ts, _, _, _) -> ts)) $
         keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<<
           queryTable amountTable
-      :: MateHandler
-        [ ( Int
-          , UTCTime
-          , Int
-          , Int
-          , Bool
-          )
-        ]
     )
   if realamount < amount
   then return (Just $ amount - realamount)
@@ -199,7 +163,8 @@ postBuyProductAmountUpdate
   -> MateHandler Int
 postBuyProductAmountUpdate (PurchaseDetail pid pdamount) conn = do
   now <- liftIO getCurrentTime
-  (amount, oldprice) <- (\(_, _, am, op, _) -> (am, op)) . head <$> (
+  (amount, oldprice) <-
+    (\am -> (amountAmount am, amountPrice am)) . fromDatabase . head <$> (
       liftIO $ runSelect conn $ limit 1 $
         orderBy (desc (\(_, ts, _, _, _) -> ts)) $
           keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<<

src/Model/Auth.hs

@@ -39,6 +39,7 @@ import qualified Opaleye.Constant as C
 
 import Types.Auth
 import Types.Reader
+import Classes
 
 
 initToken :: PGS.Query
@@ -120,22 +121,12 @@ selectAuthOverviews
   -> PGS.Connection
   -> MateHandler [AuthOverview]
 selectAuthOverviews uid conn = do
-  authData <- liftIO $ runSelect conn (proc () -> do
+  liftIO $ map fromDatabase <$> runSelect conn (proc () -> do
     (adid, aduid, admethod, adcomment, _) <-
       queryTable authDataTable -< ()
     restrict -< aduid .== C.constant uid
     returnA -< (adid, adcomment, admethod)
-    ) :: MateHandler
-        [ ( Int
-          , T.Text
-          , Int
     )
-        ]
-  return $ map
-    (\(adid, adcomment, admethod) ->
-      AuthOverview adid adcomment (toEnum admethod)
-      )
-    authData
 
 
 getUserAuthInfo
@@ -144,24 +135,16 @@ getUserAuthInfo
   -> PGS.Connection
   -> MateHandler AuthInfo
 getUserAuthInfo uid method conn = do
-  authdata <- map (\(aid, auid, amethod, acomment, apayload) ->
+  authdata <-
-    (aid, auid, amethod, acomment, decodeUtf8 $ B64.encode apayload)) <$>
+    liftIO $ do
-    liftIO (do
       void $ threadDelay delayTime
-      runSelect conn (proc () -> do
+      map fromDatabase <$> runSelect conn (proc () -> do
         (aid, auid, amethod, acomment, apayload) <-
           queryTable authDataTable -< ()
         restrict -<
           auid .== C.constant uid .&& amethod .== C.constant (fromEnum method)
         returnA -< (aid, auid, amethod, acomment, apayload)
-        ) :: IO
+        ) :: IO [AuthData]
-            [ ( Int
-              , Int
-              , Int
-              , T.Text
-              , ByteString
-              )
-            ])
   if null authdata
   then
     -- generate mock AuthInfo
@@ -215,21 +198,15 @@ validateToken
   -> PGS.Connection
   -> Handler (Maybe (Int, AuthMethod))
 validateToken header conn = do
-  tokens <- liftIO $ runSelect conn (
+  tokens <- liftIO $ map fromDatabase <$> runSelect conn (
     keepWhen (\(tstr, _, _, _) ->
       tstr .== C.constant (decodeUtf8 header)) <<< queryTable tokenTable
-    ) :: Handler
-        [ ( T.Text
-          , Int
-          , UTCTime
-          , Int
     )
-        ]
   case tokens of
-    [(_, uid, stamp, method)] -> do
+    [(Token _ uid stamp method)] -> do
       now <- liftIO getCurrentTime
       if diffUTCTime stamp now > 0
-      then return $ Just (uid, toEnum method)
+      then return $ Just (uid, method)
       else do
         void $ deleteToken (decodeUtf8 header) conn
         liftIO $ threadDelay delayTime
@@ -249,22 +226,13 @@ generateToken
   -> PGS.Connection
   -> MateHandler AuthResult
 generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
-  authData <- liftIO $ runSelect conn (
+  authData <- liftIO $ map fromDatabase <$> runSelect conn (
     keepWhen (\(_, auid, amethod, _, _) ->
       auid .== C.constant tuid .&& amethod .== C.constant (fromEnum method))
         <<< queryTable authDataTable
-    ) :: MateHandler
+    ) :: MateHandler [AuthData]
-        [ ( Int
-          , Int
-          , Int
-          , T.Text
-          , ByteString
-          )
-        ]
   let userPayloads = map
-        (\(_, _, _, _, payload) ->
+        authDataPayload
-          decodeUtf8 payload
-          )
         authData
       authResult = case method of
         PrimaryPass       -> validatePass response userPayloads

src/Model/Product.hs

@@ -4,7 +4,8 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 module Model.Product where
 
-import Data.Text as T hiding (head, foldl)
+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)
@@ -23,6 +24,7 @@ import Opaleye.Constant as C
 -- internal imports
 
 import Types
+import Classes
 import Model.Amount
 
 initProduct :: PGS.Query
@@ -80,25 +82,9 @@ productSelect
   :: PGS.Connection
   -> MateHandler [Product]
 productSelect conn = do
-  prods <- liftIO $ runSelect conn
+  liftIO $ map fromDatabase <$> runSelect conn
     ( keepWhen (\_ -> C.constant True) <<< 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
 
 
 productSelectSingle

src/Types/Amount.hs

@@ -1,10 +1,17 @@
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeFamilies #-}
 module Types.Amount where
 
 import GHC.Generics
 
 import Data.Aeson
 
+import Data.Time (UTCTime)
+
+-- internal imports
+
+import Classes
+
 data AmountUpdate = AmountUpdate
   { amountUpdateProductId  :: Int
   , amountUpdateRealAmount :: Int
@@ -28,3 +35,27 @@ instance ToJSON AmountRefill where
   toEncoding = genericToEncoding defaultOptions
 
 instance FromJSON AmountRefill
+
+
+data Amount = Amount
+  { amountProductId :: Int
+  , amountTimestamp :: UTCTime
+  , amountAmount    :: Int
+  , amountPrice     :: Int
+  , amountVerified  :: Bool
+  }
+  deriving (Show)
+
+instance ToDatabase Amount where
+
+  type InTuple Amount = (Int, UTCTime, Int, Int, Bool)
+
+  toDatabase (Amount pid ts amount price ver) =
+    (pid, ts, amount, price, ver)
+
+instance FromDatabase Amount where
+
+  type OutTuple Amount = (Int, UTCTime, Int, Int, Bool)
+
+  fromDatabase (pid, ts, amount, price, ver) =
+    Amount pid ts amount price ver

src/Types/Auth.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE TypeFamilies #-}
 module Types.Auth where
 
 import GHC.Generics
@@ -10,12 +11,18 @@ import qualified Data.Set as S
 
 import Data.Time.Clock (UTCTime)
 
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Base64 as B64
+
 import qualified Data.Text as T
+import Data.Text.Encoding
 
 import Control.Concurrent.STM.TVar (TVar)
 
 -- internal imports
 
+import Classes
+
 data TicketRequest = TicketRequest
   { ticketRequestUser   :: Int
   , ticketRequestMethod :: AuthMethod
@@ -39,6 +46,20 @@ instance ToJSON AuthInfo where
 
 instance FromJSON AuthInfo
 
+-- instance ToDatabase AuthInfo where
+-- 
+--   type InTuple AuthInfo = (Maybe T.Text, T.Text)
+-- 
+--   toDatabase (AuthInfo mChallenge (AuthTicket ticket)) =
+--     (mChallenge, ticket)
+
+instance FromDatabase AuthInfo where
+
+  type OutTuple AuthInfo = (Maybe T.Text, T.Text)
+
+  fromDatabase (mChallenge, ticket) =
+    AuthInfo mChallenge (AuthTicket ticket)
+
 
 data AuthMethod
   = PrimaryPass
@@ -122,6 +143,20 @@ data Token = Token
   }
   deriving (Generic, Show)
 
+-- instance ToDatabase Token where
+-- 
+--   type InTuple Token = (T.Text, Int, UTCTime, Int)
+-- 
+--   toDatabase (Token string usr exp method) =
+--     (string, usr, exp, fromEnum method)
+
+instance FromDatabase Token where
+
+  type OutTuple Token = (T.Text, Int, UTCTime, Int)
+
+  fromDatabase (string, usr, exp, method) =
+    Token string usr exp (toEnum method)
+
 
 type TicketStore = TVar (S.Set Ticket)
 
@@ -147,6 +182,20 @@ data AuthData = AuthData
   }
   deriving (Show)
 
+-- instance ToDatabase AuthData where
+-- 
+--   type InTuple AuthData = (Int, Int, Int, T.Text, ByteString)
+-- 
+--   toDatabase (AuthData id_ usr method comm payload) =
+--     (id_, usr, fromEnum method, comm, (B64.decode $ encodeUtf8 payload))
+
+instance FromDatabase AuthData where
+
+  type OutTuple AuthData = (Int, Int, Int, T.Text, ByteString)
+
+  fromDatabase (id_, usr, method, comm, payload) =
+    AuthData id_ usr (toEnum method) comm (decodeUtf8 $ B64.encode payload)
+
 
 data AuthOverview = AuthOverview
   { authOverviewId      :: Int
@@ -159,3 +208,17 @@ instance ToJSON AuthOverview where
   toEncoding = genericToEncoding defaultOptions
 
 instance FromJSON AuthOverview
+
+-- instance ToDatabase AuthOverview where
+-- 
+--   type InTuple AuthOverview = (Int, T.Text, Int)
+-- 
+--   toDatabase (AuthOverview id_ comm method) =
+--     (id_, comm, fromEnum method)
+
+instance FromDatabase AuthOverview where
+
+  type OutTuple AuthOverview = (Int, T.Text, Int)
+
+  fromDatabase (id_, comm, method) =
+    AuthOverview id_ comm (toEnum method)

src/Types/Product.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeFamilies #-}
 module Types.Product where
 
 import GHC.Generics
@@ -7,6 +8,10 @@ import Data.Aeson
 
 import qualified Data.Text as T
 
+-- internal imports
+
+import Classes
+
 data Product = Product
   { productId             :: Int
   , productIdent          :: T.Text
@@ -28,6 +33,22 @@ instance ToJSON Product where
 
 instance FromJSON Product
 
+instance ToDatabase Product where
+
+  type InTuple Product =
+    (Int, T.Text, Int, Maybe Int, Maybe Int, Int, Int, Maybe Int, Maybe T.Text)
+
+  toDatabase (Product id_ ident ml maid msid maxa apc ppc artnr) =
+    (id_, ident, ml, maid, msid, maxa, apc, ppc, artnr)
+
+instance FromDatabase Product where
+
+  type OutTuple Product =
+    (Int, T.Text, Int, Maybe Int, Maybe Int, Int, Int, Maybe Int, Maybe T.Text)
+
+  fromDatabase (id_, ident, ml, maid, msid, maxa, apc, ppc, artnr) =
+    Product id_ ident ml maid msid maxa apc ppc artnr
+
 
 data ProductOverview = ProductOverview
   { productOverviewId             :: Int

src/Types/Role.hs

@@ -5,6 +5,8 @@ module Types.Role where
 import qualified Data.Text as T
 import Data.Aeson
 
+import Data.Time (UTCTime)
+
 import GHC.Generics
 
 -- internal imports