From cc54dc531485d51d98495c25cb81d8f4970c4d84 Mon Sep 17 00:00:00 2001
From: nek0 <nek0@nek0.eu>
Date: Sun, 24 Jul 2022 15:26:55 +0200
Subject: [PATCH] invent DatabaseRepresentation tyeclass and apply it

---
 mateamt.cabal                         |  1 +
 src/Classes.hs                        |  1 +
 src/Classes/DatabaseRepresentation.hs |  8 ++++++++
 src/Classes/FromDatabase.hs           | 10 ++++++----
 src/Classes/ToDatabase.hs             | 10 ++++++----
 src/Types/Amount.hs                   |  8 ++++----
 src/Types/Auth.hs                     | 24 ++++++++++++++++--------
 src/Types/Avatar.hs                   | 10 ++++++++--
 src/Types/Product.hs                  |  9 ++++-----
 src/Types/Role.hs                     | 12 +++++-------
 src/Types/Settings.hs                 |  8 ++++----
 src/Types/User.hs                     |  8 ++++----
 12 files changed, 67 insertions(+), 42 deletions(-)
 create mode 100644 src/Classes/DatabaseRepresentation.hs

diff --git a/mateamt.cabal b/mateamt.cabal
index 34d6fe0..1efed46 100644
--- a/mateamt.cabal
+++ b/mateamt.cabal
@@ -64,6 +64,7 @@ library
     Control.Journal
     Control.Meta
     Control.Avatar
+    Classes.DatabaseRepresentation
     Classes.ToDatabase
     Classes.FromDatabase
 
diff --git a/src/Classes.hs b/src/Classes.hs
index 5cdca5f..cc29e3a 100644
--- a/src/Classes.hs
+++ b/src/Classes.hs
@@ -4,3 +4,4 @@ module Classes
 
 import Classes.FromDatabase as C
 import Classes.ToDatabase as C
+import Classes.DatabaseRepresentation as C
diff --git a/src/Classes/DatabaseRepresentation.hs b/src/Classes/DatabaseRepresentation.hs
new file mode 100644
index 0000000..8b9f302
--- /dev/null
+++ b/src/Classes/DatabaseRepresentation.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE TypeFamilies #-}
+module Classes.DatabaseRepresentation where
+
+import Data.Kind (Type)
+
+class DatabaseRepresentation a where
+
+  type Representation a :: Type
diff --git a/src/Classes/FromDatabase.hs b/src/Classes/FromDatabase.hs
index 8975799..f2bafe8 100644
--- a/src/Classes/FromDatabase.hs
+++ b/src/Classes/FromDatabase.hs
@@ -1,10 +1,12 @@
 {-# LANGUAGE TypeFamilies #-}
 module Classes.FromDatabase where
 
-import Data.Kind (Type)
+-- internal imports
 
-class FromDatabase a where
+import Classes.DatabaseRepresentation
 
-  type OutTuple a :: Type
+class DatabaseRepresentation a => FromDatabase a where
 
-  fromDatabase :: OutTuple a -> a
+  -- type OutTuple a :: Type
+
+  fromDatabase :: Representation a -> a
diff --git a/src/Classes/ToDatabase.hs b/src/Classes/ToDatabase.hs
index 1e7e229..b070f25 100644
--- a/src/Classes/ToDatabase.hs
+++ b/src/Classes/ToDatabase.hs
@@ -1,10 +1,12 @@
 {-# LANGUAGE TypeFamilies #-}
 module Classes.ToDatabase where
 
-import Data.Kind (Type)
+-- internal imports
 
-class ToDatabase a where
+import Classes.DatabaseRepresentation
 
-  type InTuple a :: Type
+class DatabaseRepresentation a => ToDatabase a where
 
-  toDatabase :: a -> InTuple a
+  -- type InTuple a :: Type
+
+  toDatabase :: a -> Representation a
diff --git a/src/Types/Amount.hs b/src/Types/Amount.hs
index efc4ceb..23f1034 100644
--- a/src/Types/Amount.hs
+++ b/src/Types/Amount.hs
@@ -48,16 +48,16 @@ data Amount = Amount
   }
   deriving (Show)
 
-instance ToDatabase Amount where
+instance DatabaseRepresentation Amount where
 
-  type InTuple Amount = (Int, UTCTime, Int, Int, Bool)
+  type Representation Amount = (Int, UTCTime, Int, Int, Bool)
+
+instance ToDatabase Amount where
 
   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
diff --git a/src/Types/Auth.hs b/src/Types/Auth.hs
index 561c160..a4db97c 100644
--- a/src/Types/Auth.hs
+++ b/src/Types/Auth.hs
@@ -55,9 +55,11 @@ instance ToSchema AuthInfo
 --   toDatabase (AuthInfo mChallenge (AuthTicket ticket)) =
 --     (mChallenge, ticket)
 
-instance FromDatabase AuthInfo where
+instance DatabaseRepresentation AuthInfo where
 
-  type OutTuple AuthInfo = (Maybe ByteString, ByteString)
+  type Representation AuthInfo = (Maybe ByteString, ByteString)
+
+instance FromDatabase AuthInfo where
 
   fromDatabase (mChallenge, ticket) =
     AuthInfo (decodeUtf8 <$> mChallenge) (AuthTicket $ decodeUtf8 ticket)
@@ -154,9 +156,11 @@ data Token = Token
 --   toDatabase (Token string usr exp method) =
 --     (string, usr, exp, fromEnum method)
 
-instance FromDatabase Token where
+instance DatabaseRepresentation Token where
 
-  type OutTuple Token = (ByteString, Int, UTCTime, Int)
+  type Representation Token = (ByteString, Int, UTCTime, Int)
+
+instance FromDatabase Token where
 
   fromDatabase (string, usr, expiry, method) =
     Token (decodeUtf8 string) usr expiry (toEnum method)
@@ -194,9 +198,11 @@ data AuthData = AuthData
 --   toDatabase (AuthData id_ usr method comm payload) =
 --     (id_, usr, fromEnum method, comm, (B64.decode $ encodeUtf8 payload))
 
-instance FromDatabase AuthData where
+instance DatabaseRepresentation AuthData where
 
-  type OutTuple AuthData = (Int, Int, Int, T.Text, ByteString, ByteString)
+  type Representation AuthData = (Int, Int, Int, T.Text, ByteString, ByteString)
+
+instance FromDatabase AuthData where
 
   fromDatabase (id_, usr, method, comm, payload, salt) =
     AuthData id_ usr (toEnum method) comm (decodeUtf8 payload) (decodeUtf8 salt)
@@ -223,9 +229,11 @@ instance ToSchema AuthOverview
 --   toDatabase (AuthOverview id_ comm method) =
 --     (id_, comm, fromEnum method)
 
-instance FromDatabase AuthOverview where
+instance DatabaseRepresentation AuthOverview where
 
-  type OutTuple AuthOverview = (Int, Int, T.Text, Int)
+  type Representation AuthOverview = (Int, Int, T.Text, Int)
+
+instance FromDatabase AuthOverview where
 
   fromDatabase (id_, uid, comm, method) =
     AuthOverview id_ uid comm (toEnum method)
diff --git a/src/Types/Avatar.hs b/src/Types/Avatar.hs
index e7fc4bc..af54b4c 100644
--- a/src/Types/Avatar.hs
+++ b/src/Types/Avatar.hs
@@ -31,8 +31,11 @@ instance ToJSON Avatar where
 instance FromJSON Avatar
 instance ToSchema Avatar
 
+instance DatabaseRepresentation Avatar where
+
+  type Representation Avatar = (Int, T.Text, ByteString, ByteString)
+
 instance FromDatabase Avatar where
-  type OutTuple Avatar = (Int, T.Text, ByteString, ByteString)
 
   fromDatabase (id_, name, hash, data_) =
     Avatar id_ name (decodeUtf8 hash) (unpack data_)
@@ -50,8 +53,11 @@ instance ToJSON AvatarData where
 instance FromJSON AvatarData
 instance ToSchema AvatarData
 
+instance DatabaseRepresentation AvatarData where
+
+  type Representation AvatarData = (T.Text, ByteString)
+
 instance FromDatabase AvatarData where
-  type OutTuple AvatarData = (T.Text, ByteString)
 
   fromDatabase (name, data_) =
     AvatarData name (unpack data_)
diff --git a/src/Types/Product.hs b/src/Types/Product.hs
index bad5b89..a9adf70 100644
--- a/src/Types/Product.hs
+++ b/src/Types/Product.hs
@@ -36,19 +36,18 @@ instance ToJSON Product where
 instance FromJSON Product
 instance ToSchema Product
 
-instance ToDatabase Product where
+instance DatabaseRepresentation Product where
 
-  type InTuple Product =
+  type Representation Product =
     (Int, T.Text, Int, Maybe Int, Maybe Int, Int, Int, Int, Maybe Int, Maybe T.Text)
 
+instance ToDatabase Product where
+
   toDatabase (Product id_ ident ml maid msid maxa mina apc ppc artnr) =
     (id_, ident, ml, maid, msid, maxa, mina, apc, ppc, artnr)
 
 instance FromDatabase Product where
 
-  type OutTuple Product =
-    (Int, T.Text, Int, Maybe Int, Maybe Int, Int, Int, Int, Maybe Int, Maybe T.Text)
-
   fromDatabase (id_, ident, ml, maid, msid, maxa, mina, apc, ppc, artnr) =
     Product id_ ident ml maid msid maxa mina apc ppc artnr
 
diff --git a/src/Types/Role.hs b/src/Types/Role.hs
index 399d7e2..6ecb6c1 100644
--- a/src/Types/Role.hs
+++ b/src/Types/Role.hs
@@ -9,8 +9,7 @@ import GHC.Generics
 
 -- internal imports
 
-import Classes.ToDatabase
-import Classes.FromDatabase
+import Classes
 
 data Role = Role
   { roleID                 :: Int
@@ -37,19 +36,18 @@ instance ToJSON Role where
 instance FromJSON Role
 instance ToSchema Role
 
-instance ToDatabase Role where
+instance DatabaseRepresentation Role where
 
-  type InTuple Role =
+  type Representation Role =
     (Int, T.Text, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool)
 
+instance ToDatabase Role where
+
   toDatabase (Role id_ name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10) =
     (id_, name, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10)
 
 instance FromDatabase Role where
 
-  type OutTuple Role =
-    (Int, T.Text, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool)
-
   fromDatabase (id_, name, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10) =
     Role id_ name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10
 
diff --git a/src/Types/Settings.hs b/src/Types/Settings.hs
index 198fe53..a20885e 100644
--- a/src/Types/Settings.hs
+++ b/src/Types/Settings.hs
@@ -13,14 +13,14 @@ data Settings = Settings
   }
   deriving (Show)
 
-instance ToDatabase Settings where
+instance DatabaseRepresentation Settings where
 
-  type InTuple Settings = (Bool, T.Text)
+  type Representation Settings = (Bool, T.Text)
+
+instance ToDatabase Settings where
 
   toDatabase (Settings reg imprint) = (reg, imprint)
 
 instance FromDatabase Settings where
 
-  type OutTuple Settings = (Bool, T.Text)
-
   fromDatabase (reg, imprint) = Settings reg imprint
diff --git a/src/Types/User.hs b/src/Types/User.hs
index ebf9675..99029ad 100644
--- a/src/Types/User.hs
+++ b/src/Types/User.hs
@@ -28,17 +28,17 @@ data User
     }
   deriving (Generic, Show)
 
-instance ToDatabase User where
+instance DatabaseRepresentation User where
 
-  type InTuple User = (Int, T.Text, Int, Day, Maybe T.Text, Maybe Int)
+  type Representation User = (Int, T.Text, Int, Day, Maybe T.Text, Maybe Int)
+
+instance ToDatabase User where
 
   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