diff options
author | William Carroll <wpcarro@gmail.com> | 2020-07-27T14·22+0100 |
---|---|---|
committer | William Carroll <wpcarro@gmail.com> | 2020-07-27T14·22+0100 |
commit | 475f62fb16fb29e55548cc8b238caea8bf60bd8f (patch) | |
tree | 8e97b206c86c7022443b8e09f42aad8a0b0b8a60 /src/Types.hs | |
parent | c38814d7a155e5ced75b088b29cafa71a4a76de0 (diff) |
Prefer SQLite.Simple to Persistent
In the spirit of walking crawling before I walk, I'm preferring the less powerful SQLite.Simple library to the more powerful (but mystifying) Persistent library.
Diffstat (limited to 'src/Types.hs')
-rw-r--r-- | src/Types.hs | 147 |
1 files changed, 108 insertions, 39 deletions
diff --git a/src/Types.hs b/src/Types.hs index 083724961a58..d57fa92ed31e 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -10,58 +11,126 @@ module Types where -------------------------------------------------------------------------------- import Data.Aeson +import Data.Function ((&)) import Data.Text +import Data.Typeable import Database.Persist.TH +import Database.SQLite.Simple +import Database.SQLite.Simple.Ok +import Database.SQLite.Simple.FromField +import Database.SQLite.Simple.ToField +import GHC.Generics + +import qualified Data.ByteString as BS -------------------------------------------------------------------------------- -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -Account - username Text - password Text - email Text - role Text - UniqueUsername username - UniqueEmail email - deriving Eq Read Show -|] - -instance FromJSON Account where - parseJSON = withObject "Account" $ \ v -> - Account <$> v .: "username" - <*> v .: "password" - <*> v .: "email" - <*> v .: "role" - -instance ToJSON Account where - toJSON (Account{ accountUsername - , accountPassword - , accountEmail - , accountRole }) = - object [ "username" .= accountUsername - , "password" .= accountPassword - , "email" .= accountEmail - , "role" .= accountRole - ] +-- TODO(wpcarro): Properly handle NULL for columns like profilePicture. +forNewtype :: (Typeable b) => (Text -> b) -> FieldParser b +forNewtype wrapper field = + case fieldData field of + (SQLText x) -> Ok (wrapper x) + _ -> returnError ConversionFailed field "" newtype Username = Username Text - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance ToJSON Username +instance FromJSON Username -instance ToJSON Username where - toJSON (Username x) = toJSON x +instance ToField Username where + toField (Username x) = SQLText x + +instance FromField Username where + fromField = forNewtype Username newtype Password = Password Text - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance ToJSON Password +instance FromJSON Password + +instance ToField Password where + toField (Password x) = SQLText x + +instance FromField Password where + fromField = forNewtype Password + +newtype Email = Email Text + deriving (Eq, Show, Generic) + +instance ToJSON Email +instance FromJSON Email + +instance ToField Email where + toField (Email x) = SQLText x -instance ToJSON Password where - toJSON (Password x) = toJSON x +instance FromField Email where + fromField = forNewtype Email data Role = RegularUser | Manager | Admin - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance ToJSON Role +instance FromJSON Role + +instance ToField Role where + toField RegularUser = SQLText "user" + toField Manager = SQLText "manager" + toField Admin = SQLText "admin" + +instance FromField Role where + fromField field = + case fieldData field of + (SQLText "user") -> Ok RegularUser + (SQLText "manager") -> Ok Manager + (SQLText "admin") -> Ok Admin + _ -> returnError ConversionFailed field "" + +-- TODO(wpcarro): Prefer Data.ByteString instead of Text +newtype ProfilePicture = ProfilePicture Text + deriving (Eq, Show, Generic) + +instance ToJSON ProfilePicture +instance FromJSON ProfilePicture + +instance ToField ProfilePicture where + toField (ProfilePicture x) = SQLText x + +instance FromField ProfilePicture where + fromField = forNewtype ProfilePicture + +data Account = Account + { accountUsername :: Username + , accountPassword :: Password + , accountEmail :: Email + , accountRole :: Role + , accountProfilePicture :: ProfilePicture + } deriving (Eq, Show, Generic) + +instance FromJSON Account +instance ToJSON Account + +-- | Return a tuple with all of the fields for an Account record to use for SQL. +accountFields :: Account -> (Username, Password, Email, Role, ProfilePicture) +accountFields (Account { accountUsername + , accountPassword + , accountEmail + , accountRole + , accountProfilePicture + }) + = ( accountUsername + , accountPassword + , accountEmail + , accountRole + , accountProfilePicture + ) -instance ToJSON Role where - toJSON RegularUser = "user" - toJSON Manager = "manager" - toJSON Admin = "admin" +instance FromRow Account where + fromRow = Account <$> field + <*> field + <*> field + <*> field + <*> field data Session = Session { username :: Username |