initial work on using entities directly and using entity monad directly

app/Api/Api.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
 
 module Api.Api where
 
@@ -14,7 +15,7 @@ import Data.Time.Clock.POSIX (getPOSIXTime)
 import Data.UUID (toString)
 import Data.UUID.V4 (nextRandom)
 
-import Network.HTTP.Types.Status (Status, status200, status400, status404)
+import Network.HTTP.Types.Status (Status, status200, status400, status404, status500)
 import Network.Wai (Request (pathInfo, requestMethod), getRequestBodyChunk)
 
 import Crypto.Random (getRandomBytes)
@@ -23,8 +24,8 @@ import Data.ByteString.Lazy (fromStrict, toStrict)
 import Data.Password.Bcrypt (PasswordCheck (PasswordCheckFail, PasswordCheckSuccess), PasswordHash (PasswordHash), checkPassword, mkPassword)
 import Data.Text (intercalate, pack, unpack, Text)
 import Data.Text.Array (Array (ByteArray))
-import Database.Persist (Entity (Entity), Filter (Filter), FilterValue (FilterValue), PersistFilter (BackendSpecificFilter), insertEntity, selectList, PersistQueryWrite (deleteWhere), (==.), (=.))
-import Database.Schema (EntityField (TokenName, UserName, UserIndex, VisitIndex, GuestbookEntryIndex, SnakeIndex, TokenIndex, VisitUuid, TokenToken), GuestbookEntry (GuestbookEntry, guestbookEntryContent, guestbookEntryName, guestbookEntryParentId, guestbookEntryIndex, guestbookEntryTimestamp), Snake (Snake), Token (Token, tokenToken), User (User, userName, userPassword), Visit (Visit))
+import Database.Persist (Entity (Entity, entityKey), Filter (Filter), FilterValue (FilterValue), PersistFilter (BackendSpecificFilter), insertEntity, selectList, PersistQueryWrite (deleteWhere), (==.), (=.), PersistField (toPersistValue), PersistStoreRead (get))
+import Database.Schema (EntityField (TokenName, UserName, VisitUuid, TokenToken, GuestbookEntryId, VisitId, SnakeId, UserId, TokenId, GuestbookEntryParentId), GuestbookEntry (GuestbookEntry, guestbookEntryContent, guestbookEntryName, guestbookEntryParentId, guestbookEntryTimestamp), Snake (Snake), Token (Token, tokenToken), User (User, userName, userPassword), Visit (Visit), Key (GuestbookEntryKey))
 import Logger (info)
 import Text.StringRandom (stringRandomIO)
 
@@ -38,6 +39,7 @@ import System.Directory (getDirectoryContents, removeFile)
 import Settings (getEditorRoot)
 import Tables (DatabaseDelete(DatabaseDelete, EmptyDatabaseDelete))
 import State (getCookies, getStates, loggedIn, accessToken)
+import Database.Persist.Sql (toSqlKey)
 
 type Header = (HeaderName, ByteString)
 type APIResponse = IO (Status, String, [Header])
@@ -79,10 +81,10 @@ apiMap = [
                     let pass = mkPassword $ pack password
                     rows <- getData [UserName ==. username] []
                     case rows of
-                        [user] -> case checkPassword pass (PasswordHash $ pack (userPassword user)) of
+                        [Entity id user] -> case checkPassword pass (PasswordHash $ pack (userPassword user)) of
                             PasswordCheckSuccess -> do
                                 token <- stringRandomIO "[0-9a-zA-Z]{4}-[0-9a-ZA-Z]{10}-[0-9a-zA-Z]{15}"
-                                runDb $ insertEntity $ Token 0 (unpack token) username
+                                runDb $ insertEntity $ Token (unpack token) username
                                 return (status200, j2s [aesonQQ|{"token":#{unpack token}}|], jsonHeaders)
                             PasswordCheckFail -> return (status400, messageResponse "Error, Wrong username or password", jsonHeaders)
                         _ -> return (status400, messageResponse "Error, no user exists", jsonHeaders)
@@ -115,11 +117,11 @@ apiMap = [
             return (status200, j2s [aesonQQ|#{apiData}|], jsonHeaders)
         ),
         ("^/visits/get(/|)$", \_ -> do
-            visits <- show . length <$> (getData [] [] :: IO [Visit])
+            visits <- show . length <$> (getData [] [] :: IO [Entity Visit])
             return (status200, j2s [aesonQQ|{"visits":#{visits}}|], jsonHeaders)
         ),
         ("^/guestbook/get(/|)$", \_ -> do
-            entries <- getData [] [] :: IO [GuestbookEntry]
+            entries <- getData [] [] :: IO [Entity GuestbookEntry]
             let l = map toList entries
             return (status200, j2s [aesonQQ|{"entries":#{l}}|], jsonHeaders)
         ),
@@ -147,8 +149,11 @@ apiMap = [
                     return (status400, messageResponse "Error, content cannot be empty", jsonHeaders)
                 (T.GuestbookEntry name content parentId) -> do
                     time <- fmap round getPOSIXTime :: IO Int
-                    runDb $ insertEntity $ GuestbookEntry 0 time name content parentId
+                    runDb $ do
+                        insertEntity $ GuestbookEntry time name content parentId
                     return (status200, messageResponse "Success", jsonHeaders)
+                _ -> do
+                    return (status500, messageResponse "Error, server failed", jsonHeaders)
         ),
         ("^/snake/add(/|)$", \r -> do
             body <- getRequestBodyChunk r
@@ -157,7 +162,7 @@ apiMap = [
                 T.EmptyLeaderboard -> return (status400, messageResponse "Error, leaderboard empty", jsonHeaders)
                 (T.LeaderboardEntry name score speed fruits) -> do
                     time <- fmap round getPOSIXTime :: IO Int
-                    runDb $ insertEntity $ Snake 0 time name score speed fruits
+                    runDb $ insertEntity $ Snake time name score speed fruits
                     return (status200, messageResponse "Success", jsonHeaders)
         ),
         ("^/editor/content/.*(/|)$", \r -> do
@@ -190,15 +195,15 @@ apiMap = [
                     (DatabaseDelete table id) -> do
                         case table of
                             "visits" -> do
-                                runDb $ deleteWhere [VisitIndex ==. id]
+                                runDb $ deleteWhere [VisitId ==. (toSqlKey . read . show) id]
                             "guestbook" -> do
-                                runDb $ deleteWhere [GuestbookEntryIndex ==. id]
+                                runDb $ deleteWhere [GuestbookEntryId ==. (toSqlKey . read . show) id]
                             "snake" -> do
-                                runDb $ deleteWhere [SnakeIndex ==. id]
+                                runDb $ deleteWhere [SnakeId ==. (toSqlKey . read . show) id]
                             "users" -> do
-                                runDb $ deleteWhere [UserIndex ==. id]
+                                runDb $ deleteWhere [UserId ==. (toSqlKey . read . show) id]
                             "valid_tokens" -> do
-                                runDb $ deleteWhere [TokenIndex ==. id]
+                                runDb $ deleteWhere [TokenId ==. (toSqlKey . read . show) id]
                             _ -> putStr "no table, doing nothing..."
                         return (status200, messageResponse "ok", jsonHeaders)
                     EmptyDatabaseDelete -> return (status400, messageResponse "Invalid JSON", jsonHeaders)

app/Index.hs

@@ -4,12 +4,12 @@ import IHP.HSX.QQ (hsx)
 import Text.Blaze.Html (Html)
 
 import CodeBlock (hsxIntroCodeBlock, introCodeIndex)
-import Database.Database (AdminTable (getData), newVisit)
+import Database.Database (AdminTable (getData), newVisit, runDb)
 import Layout (layout)
 import Page (Page, PageSetting (Description, EmbedImage, EmbedText, Route))
 import Section (section)
 import Database.Schema (EntityField(VisitTimestamp, VisitUuid), Visit (Visit, visitTimestamp, visitUuid))
-import Database.Persist ((>.), (==.), SelectOpt (LimitTo, Asc, Desc))
+import Database.Persist ((>.), (==.), SelectOpt (LimitTo, Asc, Desc), Entity (Entity), selectList)
 import Network.Wai (Request, getRequestBodyChunk)
 import Utils (unpackBS)
 import State (getStates, visitId)
@@ -47,7 +47,7 @@ page :: Request -> IO Html
 page request = do
     let states = getStates request
     let uuid = visitId states
-    result <- fmap visitUuid <$> getData [VisitUuid ==. uuid] []
+    result <- getData [VisitUuid ==. uuid] []
     script <- if null result then do
         -- generate new uuid
         id <- newVisit
@@ -58,9 +58,11 @@ page request = do
         |]
     else
         return [hsx||]
-    visits <- show . length <$> (getData [] [] :: IO [Visit])
-    lastVisit <- visitTimestamp . head <$> getData [] [Desc VisitTimestamp, LimitTo 1]
-    visitsToday <- show . length <$> getData [VisitTimestamp >. lastVisit-(24*60*60)] []
+    visits <- show . length <$> (getData [] [] :: IO [Entity Visit])
+    visitsToday <- show . length <$> runDb (do
+        (Entity _ lastVisit) <- head <$> selectList [] [Desc VisitTimestamp, LimitTo 1]
+        selectList [VisitTimestamp >. visitTimestamp lastVisit-(24*60*60)] [])
+
     return [hsx|
         <h1>Skademaskinen</h1>
         <img src="/static/icon.png" style="border-radius:50%">

app/Pages/Admin/Admin.hs

@@ -2,8 +2,8 @@ module Pages.Admin.Admin where
 
 import CodeBlock (codeBlock)
 import Data.Text (Text, unpack, pack)
-import Database.Database (prettyPrintSchema, validateToken, runDb, AdminTable (button, toList, getData))
-import Database.Schema (GuestbookEntry (GuestbookEntry, guestbookEntryIndex), Snake (Snake, snakeIndex), Token (Token, tokenIndex), User (User, userIndex), Visit (Visit, visitIndex), defs, EntityField (UserName, TokenToken))
+import Database.Database (prettyPrintSchema, validateToken, runDb, AdminTable (makeButton, toList, getData))
+import Database.Schema (GuestbookEntry (GuestbookEntry), Snake (Snake), Token (Token), User (User), Visit (Visit), defs, EntityField (UserName, TokenToken))
 import IHP.HSX.QQ (hsx)
 import Layout (layout)
 import Page (Page, PageSetting (Description, Route), getArgs)
@@ -16,11 +16,11 @@ import Logger (warning)
 
 panel :: IO Html
 panel = do 
-    visits <- getData [] [] :: IO [Visit]
-    guestbook <- getData [] [] :: IO [GuestbookEntry]
-    snake <- getData [] [] :: IO [Snake]
-    users <- getData [] [] :: IO [User]
-    valid_tokens <- getData [] [] :: IO [Token]
+    visits <- getData [] [] :: IO [Entity Visit]
+    guestbook <- getData [] [] :: IO [Entity GuestbookEntry]
+    snake <- getData [] [] :: IO [Entity Snake]
+    users <- getData [] [] :: IO [Entity User]
+    valid_tokens <- getData [] [] :: IO [Entity Token]
     return [hsx|
         Here are actions when logged in
         <br>
@@ -89,25 +89,25 @@ browse table = do
     where
         getTableData :: String -> IO [([String], Html)]
         getTableData "visits" = do
-            tableData <- getData [] []:: IO [Visit]
+            tableData <- getData [] []:: IO [Entity Visit]
             let columnNames = getColumnNames "visits"
-            return $ zip (map toList tableData) (map button tableData)
+            return $ zip (map toList tableData) (map makeButton tableData)
         getTableData "guestbook" = do
-            tableData <- getData [] [] :: IO [GuestbookEntry]
+            tableData <- getData [] [] :: IO [Entity GuestbookEntry]
             let columnNames = getColumnNames "guestbook"
-            return $ zip (map toList tableData) (map button tableData)
+            return $ zip (map toList tableData) (map makeButton tableData)
         getTableData "snake" = do
-            tableData <- getData [] [] :: IO [Snake]
+            tableData <- getData [] [] :: IO [Entity Snake]
             let columnNames = getColumnNames "snake"
-            return $ zip (map toList tableData) (map button tableData)
+            return $ zip (map toList tableData) (map makeButton tableData)
         getTableData "users" = do 
-            tableData <- getData [] [] :: IO [User]
+            tableData <- getData [] [] :: IO [Entity User]
             let columnNames = getColumnNames "users"
-            return $ zip (map toList tableData) (map button tableData)
+            return $ zip (map toList tableData) (map makeButton tableData)
         getTableData "valid_tokens" = do
-            tableData <- getData [] [] :: IO [Token]
+            tableData <- getData [] [] :: IO [Entity Token]
             let columnNames = getColumnNames "valid_tokens"
-            return $ zip (map toList tableData) (map button tableData)
+            return $ zip (map toList tableData) (map makeButton tableData)
         getTableData _ = do
             return [(["Error!"], [hsx||]), (["No such table"], [hsx||])]
 

app/Pages/Guestbook/Guestbook.hs

@@ -9,19 +9,21 @@ import Data.List (filter)
 
 import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)
 import Data.Time.Format (defaultTimeLocale, formatTime)
-import Database.Schema (GuestbookEntry (GuestbookEntry))
+import Database.Schema (GuestbookEntry (GuestbookEntry), GuestbookEntryId, Key (GuestbookEntryKey), EntityField (GuestbookEntryId))
 import Layout (layout)
 import Page (Page, PageSetting (Description, Route))
 import Tree (Tree (Tree))
 import Database.Database (AdminTable(getData))
+import Database.Persist (Entity (Entity))
+import Database.Persist.MySQL (toSqlKey, BackendKey (SqlBackendKey))
 
 type Guestbook = [(Int, Int, String, String, Int)]
 
 toPosix :: Int -> POSIXTime
 toPosix n = read (show n ++ "s") :: POSIXTime
 
-prettifyGuestbook :: [Tree GuestbookEntry] -> Html
-prettifyGuestbook ((Tree (GuestbookEntry id timestamp name content parent) children) : xs) = mconcat [
+prettifyGuestbook :: [Tree (Entity GuestbookEntry)] -> Html
+prettifyGuestbook ((Tree (Entity (GuestbookEntryKey (SqlBackendKey id)) (GuestbookEntry timestamp name content parent)) children) : xs) = mconcat [
     section [hsx|
         <h3>{name} said: </h3>
         Posted: <span style="color: #ff0000">{formatTime defaultTimeLocale "%c" $ posixSecondsToUTCTime (toPosix timestamp)}</span>
@@ -39,7 +41,7 @@ prettifyGuestbook ((Tree (GuestbookEntry id timestamp name content parent) child
             </table>
         </div>
         {prettifyGuestbook $ children} 
-        {guestbookInput id True}
+        {guestbookInput (fromIntegral id) True}
         <br><br>
     |], prettifyGuestbook xs
     ]
@@ -60,13 +62,13 @@ guestbookInput parent True = [hsx|
     </div>
 |]
 
-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]
+guestbookToTree :: [Entity GuestbookEntry] -> GuestbookEntryId -> [Tree (Entity GuestbookEntry)]
+guestbookToTree entries targetParent = [Tree (Entity id (GuestbookEntry timestamp name content parent)) $ guestbookToTree entries id | (Entity id (GuestbookEntry timestamp name content parent)) <- entries, (toSqlKey . fromIntegral) parent == targetParent]
 
-getGuestbook :: IO [Tree GuestbookEntry]
+getGuestbook :: IO [Tree (Entity GuestbookEntry)]
 getGuestbook = do
-    entries <- getData [] [] :: IO [GuestbookEntry]
-    return $ guestbookToTree entries (-1)
+    entries <- getData [] [] :: IO [Entity GuestbookEntry]
+    return $ guestbookToTree entries ((toSqlKey . read . show) (-1))
 
 
 page :: IO Html

app/Pages/Projects/Snake.hs

@@ -8,6 +8,7 @@ import Layout (layout)
 import Page (Page, PageSetting (Description, Route))
 import Utils (forEach)
 import Database.Database (AdminTable(getData))
+import Database.Persist (Entity(Entity, entityVal))
 
 tile :: Int -> Html
 tile id = [hsx|
@@ -90,15 +91,15 @@ leaderboardField value = [hsx|
 |]
 
 leaderboardEntry :: Snake -> Html
-leaderboardEntry (Snake id timestamp name score speed fruits) = [hsx|
+leaderboardEntry (Snake timestamp name score speed fruits) = [hsx|
     <tr class="common-table-element">
         {mconcat $ map leaderboardField [name, show timestamp, show score, show speed, show fruits]}
     </tr>
 |]
 
 page :: IO Html
 page = do
-    l <- getData [] [] :: IO [Snake]
+    l <- getData [] [] :: IO [Entity Snake]
     return [hsx|
         <table class="common-table">
             <tr>
@@ -108,7 +109,7 @@ page = do
                 <th class="common-table-element">Speed</th>
                 <th class="common-table-element">Fruits</th>
             </tr>
-            {mconcat $ map leaderboardEntry l}
+            {mconcat $ map (\e -> leaderboardEntry $ entityVal e) l}
         </table>
     |]