rewrote database access to use persistent and mysql, this library sho…

…uld be relatively simple to use if i want to switch backend again

app/Api/Api.hs

@@ -3,8 +3,8 @@
 module Api.Api where
 
 
-import Helpers.Tables (GuestbookEntry(GuestbookEntry, EmptyGuestbook), LeaderboardEntry (EmptyLeaderboard, LeaderboardEntry), Credentials (EmptyCredentials, Credentials))
-import Helpers.Database (getVisits, uuidExists, insert, getGuestbook, getConn)
+import qualified Helpers.Tables as T (GuestbookEntry (GuestbookEntry, EmptyGuestbook), LeaderboardEntry (EmptyLeaderboard, LeaderboardEntry), Credentials (EmptyCredentials, Credentials))
+import Helpers.Database.Database (getVisits, uuidExists, getGuestbook, runDb)
 import Helpers.Utils (unpackBS, getDefault)
 
 import IHP.HSX.QQ (hsx)
@@ -19,49 +19,47 @@ import Network.HTTP.Types.Status (Status, status404, status200, status400)
 
 import Data.Aeson (encode, decode, Value (String))
 import Data.ByteString.Lazy (fromStrict, toStrict)
-import Database.SQLite.Simple (query, Only (Only))
 import Data.Password.Bcrypt (PasswordCheck(PasswordCheckSuccess, PasswordCheckFail), mkPassword, checkPassword, PasswordHash (PasswordHash))
 import Data.Text (pack, unpack)
 import Crypto.Random (getRandomBytes)
 import Data.Text.Array (Array(ByteArray))
 import Text.StringRandom (stringRandomIO)
 import Helpers.Logger (info)
+import Helpers.Database.Schema (GuestbookEntry(guestbookEntryGuestbookTimestamp, guestbookEntryGuestbookName, guestbookEntryGuestbookParentId, guestbookEntryGuestbookContent, GuestbookEntry, guestbookEntryGuestbookId), Snake (Snake), User (User, userUserPassword), Token (Token, tokenTokenToken), Visit (Visit))
+import Database.Persist (selectList, Entity (Entity), insertEntity)
 
 
 
-handleGuestbookEntry :: GuestbookEntry -> IO (Status, String)
-handleGuestbookEntry (GuestbookEntry "" _ _) = return (status400, "Error, name cannot be empty")
-handleGuestbookEntry (GuestbookEntry _ "" _) = return (status400, "Error, content cannot be empty")
-handleGuestbookEntry (GuestbookEntry name content parentId) = do
+handleGuestbookEntry :: T.GuestbookEntry -> IO (Status, String)
+handleGuestbookEntry (T.GuestbookEntry "" _ _) = return (status400, "Error, name cannot be empty")
+handleGuestbookEntry (T.GuestbookEntry _ "" _) = return (status400, "Error, content cannot be empty")
+handleGuestbookEntry (T.GuestbookEntry name content parentId) = do
     time <- fmap round getPOSIXTime :: IO Int
-    insert "INSERT INTO guestbook (name, timestamp, content, parentId) values (?, ?, ?, ?)" (name :: String, time :: Int, content :: String, parentId :: Int)
+    runDb $ insertEntity $ GuestbookEntry 0 time name content parentId
     return (status200, "Success")
-handleGuestbookEntry EmptyGuestbook = do
-    return (status400, "Error")
 
-handleLeaderboardEntry :: LeaderboardEntry -> IO (Status, String)
-handleLeaderboardEntry (LeaderboardEntry name score speed fruits) = do
+handleLeaderboardEntry :: T.LeaderboardEntry -> IO (Status, String)
+handleLeaderboardEntry (T.LeaderboardEntry name score speed fruits) = do
     time <- fmap round getPOSIXTime :: IO Int
-    insert "INSERT INTO snake (name, timestamp, score, speed, fruits) values (?, ?, ?, ?, ?)" (name :: String, time :: Int, score :: Int, speed :: Int, fruits :: Int)
+    runDb $ insertEntity $ Snake 0 time name score speed fruits
     return (status200, "Success")
-handleLeaderboardEntry EmptyLeaderboard = return (status400, "Error")
+handleLeaderboardEntry T.EmptyLeaderboard = return (status400, "Error")
 
-handleLogin :: Credentials -> IO (Status, String)
-handleLogin (Credentials username password) = do
+handleLogin :: T.Credentials -> IO (Status, String)
+handleLogin (T.Credentials username password) = do
     let pass = mkPassword $ pack password
-    conn <- getConn
-    xs <- query conn "SELECT password FROM users WHERE username = ?" (Only username)
-    case xs of
-        [Only hash] -> case checkPassword pass (PasswordHash $ pack hash) of
+    rows <- map (\(Entity _ e) -> e) <$> (runDb $ selectList [] [] :: IO [Entity User])
+    case rows of
+        [user] -> case checkPassword pass (PasswordHash $ pack (userUserPassword user)) of
             PasswordCheckSuccess -> do
-                xs <- query conn "SELECT token FROM valid_tokens where username = ?" (Only username) :: IO [Only String]
-                if null xs then do
+                rows <- map (\(Entity _ e) -> e) <$> (runDb $ selectList [] [] :: IO [Entity Token])
+                if null rows then do
                     token <- stringRandomIO "[0-9a-zA-Z]{4}-[0-9a-ZA-Z]{10}-[0-9a-zA-Z]{15}"
-                    insert "INSERT INTO valid_tokens (token, username) values (?, ?)" (unpack token :: String, username :: String)
+                    runDb $ insertEntity $ Token 0 (unpack token) username
                     return (status200, unpack token)
                 else do
-                    let (Only x) = head xs
-                    return (status200, x)
+                    let row = head rows
+                    return (status200, tokenTokenToken row)
                     where
             PasswordCheckFail -> return (status400, "Wrong username or password")
         _ -> return (status400, "Error, no user exists")
@@ -74,7 +72,7 @@ api ["visits", "new"] request = do
     if result then do
         time <- fmap round getPOSIXTime :: IO Int
         uuid <- nextRandom
-        insert "INSERT INTO visits (timestamp, uuid) values (?, ?)" (time :: Int, toString uuid :: String)
+        runDb $ insertEntity $ Visit 0 time $ toString uuid
         info "Inserted into db"
         return (status200, toString uuid)
     else
@@ -84,19 +82,19 @@ api ["visits", "get"] request = do
     return (status200, visits)
 api ["guestbook", "add"] request = do
     body <- getRequestBodyChunk request
-    let entry = getDefault EmptyGuestbook (decode (fromStrict body) :: Maybe GuestbookEntry)
+    let entry = getDefault T.EmptyGuestbook (decode (fromStrict body) :: Maybe T.GuestbookEntry)
     handleGuestbookEntry entry
 api ["guestbook", "get"] request = do
     body <- getRequestBodyChunk request
     entries <- getGuestbook
     return (status200, unpackBS $ toStrict $ encode $ show entries)
 api ["snake", "add"] request = do
     body <- getRequestBodyChunk request
-    let entry = getDefault EmptyLeaderboard (decode (fromStrict body) :: Maybe LeaderboardEntry)
+    let entry = getDefault T.EmptyLeaderboard (decode (fromStrict body) :: Maybe T.LeaderboardEntry)
     handleLeaderboardEntry entry
 api ["admin", "login"] request = do
     body <- getRequestBodyChunk request
-    let credentials = getDefault EmptyCredentials (decode (fromStrict body) :: Maybe Credentials)
+    let credentials = getDefault T.EmptyCredentials (decode (fromStrict body) :: Maybe T.Credentials)
     handleLogin credentials
 api ["hello"] _ = do
     return (status200, "Hello World!")

app/Helpers/Cli.hs

@@ -3,12 +3,13 @@ import System.Exit (exitSuccess)
 
 import Helpers.Logger (up, right, clearLine, clearEnd)
 import Data.List (intercalate)
-import Database.SQLite.Simple (Only (Only), execute)
-import Helpers.Database (getConn, initDb, insert)
-import Database.SQLite.Simple.Types (Query(Query))
 import Data.Text (pack, unpack)
 import System.IO (hFlush, stdout)
 import Data.Password.Bcrypt (mkPassword, hashPassword, PasswordHash (PasswordHash))
+import Helpers.Database.Database (runDb)
+import Database.Persist (insertEntity, PersistQueryWrite (deleteWhere))
+import Helpers.Database.Schema (User(User), EntityField (UserUserName))
+import Database.Persist.MySQL ((==.))
 
 resetCursor :: Int ->  IO ()
 resetCursor n = do
@@ -25,30 +26,22 @@ doCommand ("help":_) = do
             "",
             "exit:" ++ right 10 ++ "Exits the program",
             "help:" ++ right 10 ++ "Shows help about the CLI",
-            "drop:" ++ right 10 ++ "Deletes a table and reruns init schema",
+            "drop:" ++ right 10 ++ "Deletes a table and reruns init schema :: REMOVED",
             "adduser:" ++ right 7 ++ "Adds a user to the users table",
             "removeuser:" ++ right 4 ++ "removes a user from the users table"
             ]
-doCommand ["drop", table] = do
-    conn <- getConn
-    execute conn (Query $ pack ("DROP TABLE "++table)) ()
-    putStrLn "Successfully dropped table"
-    resetCursor 2
-    initDb
-    cli
 doCommand ("exit":_) = do 
     putStrLn "Exiting"
     exitSuccess
 doCommand ["adduser", username, password] = do
     let pass = mkPassword $ pack password
     (PasswordHash hash) <- hashPassword pass
-    insert "INSERT INTO users(username, password) VALUES (?, ?)" (username :: String, unpack hash :: String)
+    runDb $ insertEntity $ User 0 username $ unpack hash
     putStrLn "Successfully added user"
     resetCursor 2
     cli
 doCommand ["removeuser", username] = do
-    conn <- getConn
-    execute conn "DELETE FROM users WHERE username = ?" (Only username)
+    runDb $ deleteWhere [UserUserName ==. username]
     putStrLn "Successfully removed user"
     resetCursor 2
     cli

app/Helpers/Database/Database.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE OverloadedStrings          #-}
+module Helpers.Database.Database where
+
+import Helpers.Settings (getDatabaseName, getDatabaseUser, getDatabaseName, getDatabaseUser)
+
+import Data.List (intercalate, inits)
+import Data.Text (pack, Text, unpack)
+import Helpers.Logger (info)
+import Helpers.Tree (Tree (Tree))
+import Database.Persist.TH (share, mkPersist, sqlSettings, mkMigrate, persistLowerCase)
+import Database.Persist.MySQL (ConnectInfo(ConnectInfo, connectDatabase, connectUser), defaultConnectInfo, SqlPersistT, withMySQLConn, runSqlConn, runMigration, selectList, Entity (Entity), Filter (Filter), FilterValue (FilterValue), PersistFilter (BackendSpecificFilter), EntityNameDB (unEntityNameDB), getEntityDBName, getEntityFields, FieldDef (FieldDef), fieldDBName, FieldNameHS (unFieldNameHS), PersistStoreWrite (insert_))
+import Control.Monad.Logger (NoLoggingT (runNoLoggingT))
+import Helpers.Database.Schema (migrateAll, GuestbookEntry (GuestbookEntry), Visit, Snake, EntityField (VisitVisitUuid, TokenTokenToken), defs, Token (tokenTokenName), User (userUserName))
+import Database.Persist.Types (EntityDef, FieldDef (fieldSqlType), fieldHaskell)
+
+-- Database boilerplate
+
+connectInfo :: IO ConnectInfo
+connectInfo = do
+    db <- getDatabaseName
+    user <- getDatabaseUser
+    return defaultConnectInfo {
+        connectDatabase = db,
+        connectUser = user
+    }
+
+runDb :: SqlPersistT (NoLoggingT IO) a -> IO a
+runDb cmd = do
+    info <- connectInfo
+    runNoLoggingT . withMySQLConn info . runSqlConn $ cmd
+
+doMigration :: IO ()
+doMigration = runDb $ runMigration migrateAll
+
+-- utils
+guestbookToTree :: [GuestbookEntry] -> Int -> [Tree GuestbookEntry]
+guestbookToTree entries targetParent = [Tree (GuestbookEntry id timestamp name content parent) $ guestbookToTree entries id | (GuestbookEntry id timestamp name content parent) <- entries, parent == targetParent]
+-- getters
+
+getVisits :: IO [Visit]
+getVisits = do
+    visits <- runDb $ selectList [] []
+    return $ map (\(Entity _ u) -> u) visits
+
+getGuestbook :: IO [Tree GuestbookEntry]
+getGuestbook = do
+    entries <- runDb $ selectList [] [] :: IO [Entity GuestbookEntry]
+    return $ guestbookToTree (map (\(Entity _ entry) -> entry) entries) (-1)
+
+getGuestbookEntries :: IO [GuestbookEntry]
+getGuestbookEntries = do
+    entries <- runDb $ selectList [] []
+    return $ map (\(Entity _ e) -> e) entries
+
+getLeaderboard :: IO [Snake]
+getLeaderboard = do
+    entries <- runDb $ selectList [] []
+    return $ map (\(Entity _ e) -> e) entries
+
+getUsers :: IO [User]
+getUsers = do
+    entries <- runDb $ selectList [] []
+    return $ map (\(Entity _ e) -> e) entries
+
+getTokens :: IO [Token]
+getTokens = do
+    entries <- runDb $ selectList [] []
+    return $ map (\(Entity _ e) -> e) entries
+
+uuidExists :: String -> IO Bool
+uuidExists uuid = do
+    visits <- runDb $ selectList [Filter VisitVisitUuid (FilterValue uuid) (BackendSpecificFilter "LIKE")] [] :: IO [Entity Visit]
+    print visits
+    return (visits /= [])
+
+tokenToUsername :: String -> IO String
+tokenToUsername token = do
+    (Entity _ token:_) <- runDb $ selectList [Filter TokenTokenToken (FilterValue token) (BackendSpecificFilter "LIKE")] []
+    return $ tokenTokenName token
+
+-- schema
+prettyPrintSchema :: String
+prettyPrintSchema = intercalate "\n" $ map (\(def :: EntityDef) ->
+    dbName def ++ unwords (map (\(field :: FieldDef) ->
+        "\n\t" ++fieldName field ++ replicate (20 - length (fieldName field)) ' ' ++ fieldType field) $ getEntityFields def)) defs
+    where
+        dbName :: EntityDef -> String
+        dbName entity = unpack $ unEntityNameDB $ getEntityDBName entity
+        fieldName :: FieldDef -> String
+        fieldName field = unpack $ unFieldNameHS $ fieldHaskell field
+        fieldType :: FieldDef -> String
+        fieldType field = show $ fieldSqlType field
+
+validateToken :: String -> IO Bool
+validateToken token = do
+    tokens <- getTokens
+    case tokens of
+        [] -> return False
+        _ -> return True