Skip to content

Commit 8706391

Browse files
Mast3rwaf1zMast3rwaf1z
committed
initial work on using entities directly and using entity monad directly
1 parent 5127a4d commit 8706391

File tree

8 files changed

+107
-102
lines changed

8 files changed

+107
-102
lines changed

‎app/Api/Api.hs

Lines changed: 19 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
{-# LANGUAGE OverloadedStrings #-}
2+
{-# LANGUAGE DataKinds #-}
23

34
module Api.Api where
45

@@ -14,7 +15,7 @@ import Data.Time.Clock.POSIX (getPOSIXTime)
1415
import Data.UUID (toString)
1516
import Data.UUID.V4 (nextRandom)
1617

17-
import Network.HTTP.Types.Status (Status, status200, status400, status404)
18+
import Network.HTTP.Types.Status (Status, status200, status400, status404, status500)
1819
import Network.Wai (Request (pathInfo, requestMethod), getRequestBodyChunk)
1920

2021
import Crypto.Random (getRandomBytes)
@@ -23,8 +24,8 @@ import Data.ByteString.Lazy (fromStrict, toStrict)
2324
import Data.Password.Bcrypt (PasswordCheck (PasswordCheckFail, PasswordCheckSuccess), PasswordHash (PasswordHash), checkPassword, mkPassword)
2425
import Data.Text (intercalate, pack, unpack, Text)
2526
import Data.Text.Array (Array (ByteArray))
26-
import Database.Persist (Entity (Entity), Filter (Filter), FilterValue (FilterValue), PersistFilter (BackendSpecificFilter), insertEntity, selectList, PersistQueryWrite (deleteWhere), (==.), (=.))
27-
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))
27+
import Database.Persist (Entity (Entity, entityKey), Filter (Filter), FilterValue (FilterValue), PersistFilter (BackendSpecificFilter), insertEntity, selectList, PersistQueryWrite (deleteWhere), (==.), (=.), PersistField (toPersistValue), PersistStoreRead (get))
28+
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))
2829
import Logger (info)
2930
import Text.StringRandom (stringRandomIO)
3031

@@ -38,6 +39,7 @@ import System.Directory (getDirectoryContents, removeFile)
3839
import Settings (getEditorRoot)
3940
import Tables (DatabaseDelete(DatabaseDelete, EmptyDatabaseDelete))
4041
import State (getCookies, getStates, loggedIn, accessToken)
42+
import Database.Persist.Sql (toSqlKey)
4143

4244
type Header = (HeaderName, ByteString)
4345
type APIResponse = IO (Status, String, [Header])
@@ -79,10 +81,10 @@ apiMap = [
7981
let pass = mkPassword $ pack password
8082
rows <- getData [UserName ==. username] []
8183
case rows of
82-
[user] -> case checkPassword pass (PasswordHash $ pack (userPassword user)) of
84+
[Entity id user] -> case checkPassword pass (PasswordHash $ pack (userPassword user)) of
8385
PasswordCheckSuccess -> do
8486
token <- stringRandomIO "[0-9a-zA-Z]{4}-[0-9a-ZA-Z]{10}-[0-9a-zA-Z]{15}"
85-
runDb $ insertEntity $ Token 0 (unpack token) username
87+
runDb $ insertEntity $ Token (unpack token) username
8688
return (status200, j2s [aesonQQ|{"token":#{unpack token}}|], jsonHeaders)
8789
PasswordCheckFail -> return (status400, messageResponse "Error, Wrong username or password", jsonHeaders)
8890
_ -> return (status400, messageResponse "Error, no user exists", jsonHeaders)
@@ -115,11 +117,11 @@ apiMap = [
115117
return (status200, j2s [aesonQQ|#{apiData}|], jsonHeaders)
116118
),
117119
("^/visits/get(/|)$", \_ -> do
118-
visits <- show . length <$> (getData [] [] :: IO [Visit])
120+
visits <- show . length <$> (getData [] [] :: IO [Entity Visit])
119121
return (status200, j2s [aesonQQ|{"visits":#{visits}}|], jsonHeaders)
120122
),
121123
("^/guestbook/get(/|)$", \_ -> do
122-
entries <- getData [] [] :: IO [GuestbookEntry]
124+
entries <- getData [] [] :: IO [Entity GuestbookEntry]
123125
let l = map toList entries
124126
return (status200, j2s [aesonQQ|{"entries":#{l}}|], jsonHeaders)
125127
),
@@ -147,8 +149,11 @@ apiMap = [
147149
return (status400, messageResponse "Error, content cannot be empty", jsonHeaders)
148150
(T.GuestbookEntry name content parentId) -> do
149151
time <- fmap round getPOSIXTime :: IO Int
150-
runDb $ insertEntity $ GuestbookEntry 0 time name content parentId
152+
runDb $ do
153+
insertEntity $ GuestbookEntry time name content parentId
151154
return (status200, messageResponse "Success", jsonHeaders)
155+
_ -> do
156+
return (status500, messageResponse "Error, server failed", jsonHeaders)
152157
),
153158
("^/snake/add(/|)$", \r -> do
154159
body <- getRequestBodyChunk r
@@ -157,7 +162,7 @@ apiMap = [
157162
T.EmptyLeaderboard -> return (status400, messageResponse "Error, leaderboard empty", jsonHeaders)
158163
(T.LeaderboardEntry name score speed fruits) -> do
159164
time <- fmap round getPOSIXTime :: IO Int
160-
runDb $ insertEntity $ Snake 0 time name score speed fruits
165+
runDb $ insertEntity $ Snake time name score speed fruits
161166
return (status200, messageResponse "Success", jsonHeaders)
162167
),
163168
("^/editor/content/.*(/|)$", \r -> do
@@ -190,15 +195,15 @@ apiMap = [
190195
(DatabaseDelete table id) -> do
191196
case table of
192197
"visits" -> do
193-
runDb $ deleteWhere [VisitIndex ==. id]
198+
runDb $ deleteWhere [VisitId ==. (toSqlKey . read . show) id]
194199
"guestbook" -> do
195-
runDb $ deleteWhere [GuestbookEntryIndex ==. id]
200+
runDb $ deleteWhere [GuestbookEntryId ==. (toSqlKey . read . show) id]
196201
"snake" -> do
197-
runDb $ deleteWhere [SnakeIndex ==. id]
202+
runDb $ deleteWhere [SnakeId ==. (toSqlKey . read . show) id]
198203
"users" -> do
199-
runDb $ deleteWhere [UserIndex ==. id]
204+
runDb $ deleteWhere [UserId ==. (toSqlKey . read . show) id]
200205
"valid_tokens" -> do
201-
runDb $ deleteWhere [TokenIndex ==. id]
206+
runDb $ deleteWhere [TokenId ==. (toSqlKey . read . show) id]
202207
_ -> putStr "no table, doing nothing..."
203208
return (status200, messageResponse "ok", jsonHeaders)
204209
EmptyDatabaseDelete -> return (status400, messageResponse "Invalid JSON", jsonHeaders)

‎app/Index.hs

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -4,12 +4,12 @@ import IHP.HSX.QQ (hsx)
44
import Text.Blaze.Html (Html)
55

66
import CodeBlock (hsxIntroCodeBlock, introCodeIndex)
7-
import Database.Database (AdminTable (getData), newVisit)
7+
import Database.Database (AdminTable (getData), newVisit, runDb)
88
import Layout (layout)
99
import Page (Page, PageSetting (Description, EmbedImage, EmbedText, Route))
1010
import Section (section)
1111
import Database.Schema (EntityField(VisitTimestamp, VisitUuid), Visit (Visit, visitTimestamp, visitUuid))
12-
import Database.Persist ((>.), (==.), SelectOpt (LimitTo, Asc, Desc))
12+
import Database.Persist ((>.), (==.), SelectOpt (LimitTo, Asc, Desc), Entity (Entity), selectList)
1313
import Network.Wai (Request, getRequestBodyChunk)
1414
import Utils (unpackBS)
1515
import State (getStates, visitId)
@@ -47,7 +47,7 @@ page :: Request -> IO Html
4747
page request = do
4848
let states = getStates request
4949
let uuid = visitId states
50-
result <- fmap visitUuid <$> getData [VisitUuid ==. uuid] []
50+
result <- getData [VisitUuid ==. uuid] []
5151
script <- if null result then do
5252
-- generate new uuid
5353
id <- newVisit
@@ -58,9 +58,11 @@ page request = do
5858
|]
5959
else
6060
return [hsx||]
61-
visits <- show . length <$> (getData [] [] :: IO [Visit])
62-
lastVisit <- visitTimestamp . head <$> getData [] [Desc VisitTimestamp, LimitTo 1]
63-
visitsToday <- show . length <$> getData [VisitTimestamp >. lastVisit-(24*60*60)] []
61+
visits <- show . length <$> (getData [] [] :: IO [Entity Visit])
62+
visitsToday <- show . length <$> runDb (do
63+
(Entity _ lastVisit) <- head <$> selectList [] [Desc VisitTimestamp, LimitTo 1]
64+
selectList [VisitTimestamp >. visitTimestamp lastVisit-(24*60*60)] [])
65+
6466
return [hsx|
6567
<h1>Skademaskinen</h1>
6668
<img src="/static/icon.png" style="border-radius:50%">

‎app/Pages/Admin/Admin.hs

Lines changed: 17 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -2,8 +2,8 @@ module Pages.Admin.Admin where
22

33
import CodeBlock (codeBlock)
44
import Data.Text (Text, unpack, pack)
5-
import Database.Database (prettyPrintSchema, validateToken, runDb, AdminTable (button, toList, getData))
6-
import Database.Schema (GuestbookEntry (GuestbookEntry, guestbookEntryIndex), Snake (Snake, snakeIndex), Token (Token, tokenIndex), User (User, userIndex), Visit (Visit, visitIndex), defs, EntityField (UserName, TokenToken))
5+
import Database.Database (prettyPrintSchema, validateToken, runDb, AdminTable (makeButton, toList, getData))
6+
import Database.Schema (GuestbookEntry (GuestbookEntry), Snake (Snake), Token (Token), User (User), Visit (Visit), defs, EntityField (UserName, TokenToken))
77
import IHP.HSX.QQ (hsx)
88
import Layout (layout)
99
import Page (Page, PageSetting (Description, Route), getArgs)
@@ -16,11 +16,11 @@ import Logger (warning)
1616

1717
panel :: IO Html
1818
panel = do
19-
visits <- getData [] [] :: IO [Visit]
20-
guestbook <- getData [] [] :: IO [GuestbookEntry]
21-
snake <- getData [] [] :: IO [Snake]
22-
users <- getData [] [] :: IO [User]
23-
valid_tokens <- getData [] [] :: IO [Token]
19+
visits <- getData [] [] :: IO [Entity Visit]
20+
guestbook <- getData [] [] :: IO [Entity GuestbookEntry]
21+
snake <- getData [] [] :: IO [Entity Snake]
22+
users <- getData [] [] :: IO [Entity User]
23+
valid_tokens <- getData [] [] :: IO [Entity Token]
2424
return [hsx|
2525
Here are actions when logged in
2626
<br>
@@ -89,25 +89,25 @@ browse table = do
8989
where
9090
getTableData :: String -> IO [([String], Html)]
9191
getTableData "visits" = do
92-
tableData <- getData [] []:: IO [Visit]
92+
tableData <- getData [] []:: IO [Entity Visit]
9393
let columnNames = getColumnNames "visits"
94-
return $ zip (map toList tableData) (map button tableData)
94+
return $ zip (map toList tableData) (map makeButton tableData)
9595
getTableData "guestbook" = do
96-
tableData <- getData [] [] :: IO [GuestbookEntry]
96+
tableData <- getData [] [] :: IO [Entity GuestbookEntry]
9797
let columnNames = getColumnNames "guestbook"
98-
return $ zip (map toList tableData) (map button tableData)
98+
return $ zip (map toList tableData) (map makeButton tableData)
9999
getTableData "snake" = do
100-
tableData <- getData [] [] :: IO [Snake]
100+
tableData <- getData [] [] :: IO [Entity Snake]
101101
let columnNames = getColumnNames "snake"
102-
return $ zip (map toList tableData) (map button tableData)
102+
return $ zip (map toList tableData) (map makeButton tableData)
103103
getTableData "users" = do
104-
tableData <- getData [] [] :: IO [User]
104+
tableData <- getData [] [] :: IO [Entity User]
105105
let columnNames = getColumnNames "users"
106-
return $ zip (map toList tableData) (map button tableData)
106+
return $ zip (map toList tableData) (map makeButton tableData)
107107
getTableData "valid_tokens" = do
108-
tableData <- getData [] [] :: IO [Token]
108+
tableData <- getData [] [] :: IO [Entity Token]
109109
let columnNames = getColumnNames "valid_tokens"
110-
return $ zip (map toList tableData) (map button tableData)
110+
return $ zip (map toList tableData) (map makeButton tableData)
111111
getTableData _ = do
112112
return [(["Error!"], [hsx||]), (["No such table"], [hsx||])]
113113

‎app/Pages/Guestbook/Guestbook.hs

Lines changed: 11 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -9,19 +9,21 @@ import Data.List (filter)
99

1010
import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)
1111
import Data.Time.Format (defaultTimeLocale, formatTime)
12-
import Database.Schema (GuestbookEntry (GuestbookEntry))
12+
import Database.Schema (GuestbookEntry (GuestbookEntry), GuestbookEntryId, Key (GuestbookEntryKey), EntityField (GuestbookEntryId))
1313
import Layout (layout)
1414
import Page (Page, PageSetting (Description, Route))
1515
import Tree (Tree (Tree))
1616
import Database.Database (AdminTable(getData))
17+
import Database.Persist (Entity (Entity))
18+
import Database.Persist.MySQL (toSqlKey, BackendKey (SqlBackendKey))
1719

1820
type Guestbook = [(Int, Int, String, String, Int)]
1921

2022
toPosix :: Int -> POSIXTime
2123
toPosix n = read (show n ++ "s") :: POSIXTime
2224

23-
prettifyGuestbook :: [Tree GuestbookEntry] -> Html
24-
prettifyGuestbook ((Tree (GuestbookEntry id timestamp name content parent) children) : xs) = mconcat [
25+
prettifyGuestbook :: [Tree (Entity GuestbookEntry)] -> Html
26+
prettifyGuestbook ((Tree (Entity (GuestbookEntryKey (SqlBackendKey id)) (GuestbookEntry timestamp name content parent)) children) : xs) = mconcat [
2527
section [hsx|
2628
<h3>{name} said: </h3>
2729
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
3941
</table>
4042
</div>
4143
{prettifyGuestbook $ children}
42-
{guestbookInput id True}
44+
{guestbookInput (fromIntegral id) True}
4345
<br><br>
4446
|], prettifyGuestbook xs
4547
]
@@ -60,13 +62,13 @@ guestbookInput parent True = [hsx|
6062
</div>
6163
|]
6264

63-
guestbookToTree :: [GuestbookEntry] -> Int -> [Tree GuestbookEntry]
64-
guestbookToTree entries targetParent = [Tree (GuestbookEntry id timestamp name content parent) $ guestbookToTree entries id | (GuestbookEntry id timestamp name content parent) <- entries, parent == targetParent]
65+
guestbookToTree :: [Entity GuestbookEntry] -> GuestbookEntryId -> [Tree (Entity GuestbookEntry)]
66+
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]
6567

66-
getGuestbook :: IO [Tree GuestbookEntry]
68+
getGuestbook :: IO [Tree (Entity GuestbookEntry)]
6769
getGuestbook = do
68-
entries <- getData [] [] :: IO [GuestbookEntry]
69-
return $ guestbookToTree entries (-1)
70+
entries <- getData [] [] :: IO [Entity GuestbookEntry]
71+
return $ guestbookToTree entries ((toSqlKey . read . show) (-1))
7072

7173

7274
page :: IO Html

‎app/Pages/Projects/Snake.hs

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@ import Layout (layout)
88
import Page (Page, PageSetting (Description, Route))
99
import Utils (forEach)
1010
import Database.Database (AdminTable(getData))
11+
import Database.Persist (Entity(Entity, entityVal))
1112

1213
tile :: Int -> Html
1314
tile id = [hsx|
@@ -90,15 +91,15 @@ leaderboardField value = [hsx|
9091
|]
9192

9293
leaderboardEntry :: Snake -> Html
93-
leaderboardEntry (Snake id timestamp name score speed fruits) = [hsx|
94+
leaderboardEntry (Snake timestamp name score speed fruits) = [hsx|
9495
<tr class="common-table-element">
9596
{mconcat $ map leaderboardField [name, show timestamp, show score, show speed, show fruits]}
9697
</tr>
9798
|]
9899

99100
page :: IO Html
100101
page = do
101-
l <- getData [] [] :: IO [Snake]
102+
l <- getData [] [] :: IO [Entity Snake]
102103
return [hsx|
103104
<table class="common-table">
104105
<tr>
@@ -108,7 +109,7 @@ page = do
108109
<th class="common-table-element">Speed</th>
109110
<th class="common-table-element">Fruits</th>
110111
</tr>
111-
{mconcat $ map leaderboardEntry l}
112+
{mconcat $ map (\e -> leaderboardEntry $ entityVal e) l}
112113
</table>
113114
|]
114115

0 commit comments

Comments
 (0)