From cc54dc531485d51d98495c25cb81d8f4970c4d84 Mon Sep 17 00:00:00 2001 From: nek0 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