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.

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