diff --git a/src/App.hs b/src/App.hs index 4381882d1..b80a3ba4f 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 ea2ad2621..de40b3225 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 083724961..d57fa92ed 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 where - toJSON (Username x) = toJSON x +instance ToJSON Username +instance FromJSON Username + +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 where - toJSON (Password x) = toJSON x +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 FromField Email where + fromField = forNewtype Email data Role = RegularUser | Manager | Admin - deriving (Eq, Show) + deriving (Eq, Show, Generic) -instance ToJSON Role where - toJSON RegularUser = "user" - toJSON Manager = "manager" - toJSON Admin = "admin" +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 FromRow Account where + fromRow = Account <$> field + <*> field + <*> field + <*> field + <*> field data Session = Session { username :: Username