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.

3 files changed, 128 insertions, 68 deletions

diff --git a/src/App.hs b/src/App.hs
index 4381882d192a..b80a3ba4f619 100644
--- a/src/App.hs
+++ b/src/App.hs
@@ -5,12 +5,10 @@ module App where
 --------------------------------------------------------------------------------
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Logger (runStderrLoggingT)
-import Database.Persist.Sqlite ( ConnectionPool, createSqlitePool
-                               , runSqlPool, runSqlPersistMPool
-                               , runMigration, selectFirst, (==.)
-                               , insert, entityVal)
+import Data.Function ((&))
 import Data.String.Conversions (cs)
 import Data.Text (Text)
+import Database.SQLite.Simple
 import Network.Wai.Handler.Warp as Warp
 import Servant
 
@@ -18,40 +16,33 @@ import API
 import qualified Types as T
 --------------------------------------------------------------------------------
 
-server :: ConnectionPool -> Server API
-server pool =
+server :: FilePath -> Server API
+server dbFile =
   userAddH :<|> userGetH
   where
     userAddH newUser = liftIO $ userAdd newUser
     userGetH name    = liftIO $ userGet name
 
+    -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s
     userAdd :: T.Account -> IO (Maybe T.Session)
-    userAdd newUser = flip runSqlPersistMPool pool $ do
-      exists <- selectFirst [T.AccountUsername ==. (T.accountUsername newUser)] []
-      case exists of
-        Nothing -> do
-          insert newUser
-          pure $ Just (T.Session { T.username = T.Username "wpcarro"
-                                 , T.password = T.Password "testing"
-                                 , T.role = T.RegularUser
-                                 })
-        Just _ -> pure Nothing
+    userAdd account = withConnection dbFile $ \conn -> do
+      execute conn "INSERT INTO Accounts (username,password,email,role,profilePicture) VALUES (?,?,?,?,?)"
+        (account & T.accountFields)
+      T.Session{ T.username = T.accountUsername account
+               , T.password = T.accountPassword account
+               , T.role = T.accountRole account
+               } & Just & pure
 
     userGet :: Text -> IO (Maybe T.Account)
-    userGet name = flip runSqlPersistMPool pool $ do
-      mUser <- selectFirst [T.AccountUsername ==. name] []
-      pure $ entityVal <$> mUser
-
-app :: ConnectionPool -> Application
-app pool = serve (Proxy @ API) $ server pool
+    userGet name = withConnection dbFile $ \conn -> do
+      res <- query conn "SELECT * FROM Accounts WHERE username = ?" (Only name)
+      case res of
+        [x] -> pure (Just x)
+        _   -> pure Nothing
 
 mkApp :: FilePath -> IO Application
-mkApp sqliteFile = do
-  pool <- runStderrLoggingT $ do
-    createSqlitePool (cs sqliteFile) 5
-
-  runSqlPool (runMigration T.migrateAll) pool
-  pure $ app pool
+mkApp dbFile = do
+  pure $ serve (Proxy @ API) $ server dbFile
 
 run :: FilePath -> IO ()
 run sqliteFile =
diff --git a/src/Main.hs b/src/Main.hs
index ea2ad2621bd9..de40b3225e4a 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -4,4 +4,4 @@ import qualified App
 --------------------------------------------------------------------------------
 
 main :: IO ()
-main = App.run "sqlite.db"
+main = App.run "../db.sqlite3"
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