diff --git a/app/Api/Api.hs b/app/Api/Api.hs
index cbe6a6e..b27ee6c 100644
--- a/app/Api/Api.hs
+++ b/app/Api/Api.hs
@@ -2,7 +2,7 @@
module Api.Api where
-import Database.Database (getGuestbook, getVisits, runDb, uuidExists, validateToken, AdminTable (getData))
+import Database.Database (runDb, AdminTable (getData), toList, validateToken)
import Pages.Projects.Brainfuck (code)
import qualified Tables as T (Credentials (Credentials, EmptyCredentials), GuestbookEntry (EmptyGuestbook, GuestbookEntry), LeaderboardEntry (EmptyLeaderboard, LeaderboardEntry))
import Utils (getDefault, unpackBS)
@@ -23,8 +23,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), GuestbookEntry (GuestbookEntry, guestbookEntryContent, guestbookEntryName, guestbookEntryParentId, guestbookEntryIndex, guestbookEntryTimestamp), Snake (Snake), Token (Token, tokenToken), User (User, userName, userPassword), Visit (Visit))
+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 Logger (info)
import Text.StringRandom (stringRandomIO)
@@ -63,7 +63,7 @@ apiMap = [
("POST", [
("^/visits/new(/|)$", \r -> do
body <- getRequestBodyChunk r
- result <- uuidExists $ unpackBS body
+ result <- null <$> getData [VisitUuid ==. unpackBS body] []
res <- if result then do
time <- fmap round getPOSIXTime :: IO Int
uuid <- nextRandom
@@ -79,7 +79,7 @@ apiMap = [
case credentials of
(T.Credentials username password) -> do
let pass = mkPassword $ pack password
- rows <- getData [UserName ==. username]
+ rows <- getData [UserName ==. username] []
case rows of
[user] -> case checkPassword pass (PasswordHash $ pack (userPassword user)) of
PasswordCheckSuccess -> do
@@ -117,12 +117,13 @@ apiMap = [
return (status200, j2s [aesonQQ|#{apiData}|], jsonHeaders)
),
("^/visits/get(/|)$", \_ -> do
- visits <- show . length <$> getVisits
+ visits <- show . length <$> (getData [] [] :: IO [Visit])
return (status200, j2s [aesonQQ|{"visits":#{visits}}|], jsonHeaders)
),
("^/guestbook/get(/|)$", \_ -> do
- entries <- getGuestbook
- return (status200, j2s [aesonQQ|{"entries":#{unpackBS $ toStrict $ encode $ show entries}}|], jsonHeaders)
+ entries <- getData [] [] :: IO [GuestbookEntry]
+ let l = map toList entries
+ return (status200, j2s [aesonQQ|{"entries":#{l}}|], jsonHeaders)
),
("^/editor/sidebar(/|)$", \_ -> do
editor_root <- getEditorRoot
diff --git a/app/Index.hs b/app/Index.hs
index 5aee389..893a6fb 100644
--- a/app/Index.hs
+++ b/app/Index.hs
@@ -4,12 +4,12 @@ import IHP.HSX.QQ (hsx)
import Text.Blaze.Html (Html)
import CodeBlock (hsxIntroCodeBlock, introCodeIndex)
-import Database.Database (getVisits, AdminTable (getData))
+import Database.Database (AdminTable (getData))
import Layout (layout)
import Page (Page, PageSetting (Description, EmbedImage, EmbedText, Route))
import Section (section)
import Database.Schema (EntityField(VisitTimestamp), Visit (Visit, visitTimestamp))
-import Database.Persist ((>.))
+import Database.Persist ((>.), SelectOpt (LimitTo, Asc, Desc))
intro :: Html
intro = section [hsx|
@@ -42,9 +42,10 @@ intro = section [hsx|
page :: IO Html
page = do
- visits <- show . length <$> getVisits
- lastVisit <- foldr max 0 <$> fmap (map visitTimestamp) (getData [] :: IO [Visit])
- visitsToday <- show . length <$> getData [VisitTimestamp >. lastVisit-(24*60*60)]
+ visits <- show . length <$> (getData [] [] :: IO [Visit])
+ lastVisit <- visitTimestamp . head <$> getData [] [Desc VisitTimestamp, LimitTo 1]
+ print lastVisit
+ visitsToday <- show . length <$> getData [VisitTimestamp >. lastVisit-(24*60*60)] []
return [hsx|
Skademaskinen
diff --git a/app/Pages/Admin/Admin.hs b/app/Pages/Admin/Admin.hs
index 0dca54f..c971265 100644
--- a/app/Pages/Admin/Admin.hs
+++ b/app/Pages/Admin/Admin.hs
@@ -2,7 +2,7 @@ module Pages.Admin.Admin where
import CodeBlock (codeBlock)
import Data.Text (Text, unpack, pack)
-import Database.Database (getGuestbookEntries, getLeaderboard, getTokens, getUsers, getVisits, prettyPrintSchema, tokenToUsername, validateToken, runDb, AdminTable (button, toList, getData))
+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 IHP.HSX.QQ (hsx)
import Layout (layout)
@@ -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 [Visit]
+ guestbook <- getData [] [] :: IO [GuestbookEntry]
+ snake <- getData [] [] :: IO [Snake]
+ users <- getData [] [] :: IO [User]
+ valid_tokens <- getData [] [] :: IO [Token]
return [hsx|
Here are actions when logged in
@@ -89,23 +89,23 @@ browse table = do
where
getTableData :: String -> IO [([String], Html)]
getTableData "visits" = do
- tableData <- getData [] :: IO [Visit]
+ tableData <- getData [] []:: IO [Visit]
let columnNames = getColumnNames "visits"
return $ zip (map toList tableData) (map button tableData)
getTableData "guestbook" = do
- tableData <- getData [] :: IO [GuestbookEntry]
+ tableData <- getData [] [] :: IO [GuestbookEntry]
let columnNames = getColumnNames "guestbook"
return $ zip (map toList tableData) (map button tableData)
getTableData "snake" = do
- tableData <- getData [] :: IO [Snake]
+ tableData <- getData [] [] :: IO [Snake]
let columnNames = getColumnNames "snake"
return $ zip (map toList tableData) (map button tableData)
getTableData "users" = do
- tableData <- getData [] :: IO [User]
+ tableData <- getData [] [] :: IO [User]
let columnNames = getColumnNames "users"
return $ zip (map toList tableData) (map button tableData)
getTableData "valid_tokens" = do
- tableData <- getData [] :: IO [Token]
+ tableData <- getData [] [] :: IO [Token]
let columnNames = getColumnNames "valid_tokens"
return $ zip (map toList tableData) (map button tableData)
getTableData _ = do
diff --git a/app/Pages/Guestbook/Guestbook.hs b/app/Pages/Guestbook/Guestbook.hs
index 24d34f2..cc63557 100644
--- a/app/Pages/Guestbook/Guestbook.hs
+++ b/app/Pages/Guestbook/Guestbook.hs
@@ -3,7 +3,6 @@ module Pages.Guestbook.Guestbook where
import IHP.HSX.QQ (hsx)
import Text.Blaze.Html (Html)
-import Database.Database (getGuestbook)
import Section (section)
import Data.List (filter)
@@ -14,6 +13,7 @@ import Database.Schema (GuestbookEntry (GuestbookEntry))
import Layout (layout)
import Page (Page, PageSetting (Description, Route))
import Tree (Tree (Tree))
+import Database.Database (AdminTable(getData))
type Guestbook = [(Int, Int, String, String, Int)]
@@ -60,6 +60,16 @@ guestbookInput parent True = [hsx|
|]
+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]
+
+getGuestbook :: IO [Tree GuestbookEntry]
+getGuestbook = do
+ entries <- getData [] [] :: IO [GuestbookEntry]
+ return $ guestbookToTree entries (-1)
+
+
+page :: IO Html
page = do
guestbook <- getGuestbook
return [hsx|
diff --git a/app/Pages/Projects/Snake.hs b/app/Pages/Projects/Snake.hs
index 7599bfc..7b2bbb2 100644
--- a/app/Pages/Projects/Snake.hs
+++ b/app/Pages/Projects/Snake.hs
@@ -3,11 +3,11 @@ module Pages.Projects.Snake where
import IHP.HSX.QQ (hsx)
import Text.Blaze.Html (Html)
-import Database.Database (getLeaderboard)
import Database.Schema (Snake (Snake))
import Layout (layout)
import Page (Page, PageSetting (Description, Route))
import Utils (forEach)
+import Database.Database (AdminTable(getData))
tile :: Int -> Html
tile id = [hsx|
@@ -98,7 +98,7 @@ leaderboardEntry (Snake id timestamp name score speed fruits) = [hsx|
page :: IO Html
page = do
- l <- getLeaderboard
+ l <- getData [] [] :: IO [Snake]
return [hsx|
diff --git a/lib/Database/Database.hs b/lib/Database/Database.hs
index 656f430..cc381bc 100644
--- a/lib/Database/Database.hs
+++ b/lib/Database/Database.hs
@@ -8,10 +8,10 @@ import Settings (getDatabaseName, getDatabaseUser)
import Control.Monad.Logger (NoLoggingT (runNoLoggingT))
import Data.List (inits, intercalate)
import Data.Text (Text, pack, unpack)
-import Database.Persist.MySQL (ConnectInfo (ConnectInfo, connectDatabase, connectUser), Entity (Entity), EntityNameDB (unEntityNameDB), FieldDef (FieldDef), FieldNameHS (unFieldNameHS), Filter (Filter), FilterValue (FilterValue), PersistFilter (BackendSpecificFilter), PersistStoreWrite (insert_), SqlPersistT, defaultConnectInfo, fieldDBName, getEntityDBName, getEntityFields, runMigration, runSqlConn, selectList, withMySQLConn)
+import Database.Persist.MySQL (ConnectInfo (ConnectInfo, connectDatabase, connectUser), Entity (Entity), EntityNameDB (unEntityNameDB), FieldDef (FieldDef), FieldNameHS (unFieldNameHS), Filter (Filter), FilterValue (FilterValue), PersistFilter (BackendSpecificFilter), PersistStoreWrite (insert_), SqlPersistT, defaultConnectInfo, fieldDBName, getEntityDBName, getEntityFields, runMigration, runSqlConn, selectList, withMySQLConn, SelectOpt)
import Database.Persist.TH (mkMigrate, mkPersist, persistLowerCase, share, sqlSettings)
import Database.Persist.Types (EntityDef, FieldDef (fieldSqlType), fieldHaskell)
-import Database.Persist ((==.))
+import Database.Persist ((==.), (=.))
import Database.Schema (EntityField (TokenToken, VisitUuid), GuestbookEntry (GuestbookEntry, guestbookEntryIndex), Snake (Snake, snakeIndex), Token (tokenName, tokenToken, Token, tokenIndex), User (userName, User, userIndex), Visit (Visit, visitIndex), defs, migrateAll)
import Logger (info)
import Tree (Tree (Tree))
@@ -34,53 +34,8 @@ runDb cmd = do
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 [VisitUuid ==. uuid] [] :: IO [Entity Visit]
- print visits
- return (null visits)
-
-tokenToUsername :: String -> IO String
-tokenToUsername token = do
- (Entity _ token : _) <- runDb $ selectList [TokenToken ==. token] []
- return $ tokenName token
-
-- schema
prettyPrintSchema :: String
prettyPrintSchema =
@@ -95,29 +50,29 @@ prettyPrintSchema =
fieldType field = show $ fieldSqlType field
validateToken :: String -> IO Bool
-validateToken token = any (\x -> tokenToken x == token) <$> getTokens
+validateToken token = any (\x -> tokenToken x == token) <$> (getData [] [] :: IO [Token])
class AdminTable a where
toList :: a -> [String]
button :: a -> Html
- getData :: [Filter a] -> IO [a]
+ getData :: [Filter a] -> [SelectOpt a] -> IO [a]
instance AdminTable Visit where
toList (Visit rid timestamp uuid) = [show rid, show timestamp, uuid]
button a = [hsx||]
- getData f = map (\(Entity _ e) -> e) <$> runDb (selectList f []) :: IO [Visit]
+ getData f o = map (\(Entity _ e) -> e) <$> runDb (selectList f o) :: IO [Visit]
instance AdminTable GuestbookEntry where
toList (GuestbookEntry rid timestamp name content parentId) = [show rid, show timestamp, name, content, show parentId]
button a = [hsx||]
- getData f = map (\(Entity _ e) -> e) <$> runDb (selectList f []) :: IO [GuestbookEntry]
+ getData f o = map (\(Entity _ e) -> e) <$> runDb (selectList f o) :: IO [GuestbookEntry]
instance AdminTable Snake where
toList (Snake rid timestamp name score speed fruits) = [show rid, show timestamp, name, show score, show speed, show fruits]
button a = [hsx||]
- getData f = map (\(Entity _ e) -> e) <$> runDb (selectList f []) :: IO [Snake]
+ getData f o = map (\(Entity _ e) -> e) <$> runDb (selectList f o) :: IO [Snake]
instance AdminTable User where
toList (User rid name password) = [show rid, name, password]
- button a = [hsx|||]
- getData f = map (\(Entity _ e) -> e) <$> runDb (selectList f []) :: IO [User]
+ button a = [hsx||]
+ getData f o = map (\(Entity _ e) -> e) <$> runDb (selectList f o) :: IO [User]
instance AdminTable Token where
toList (Token rid token name) = [show rid, token, name]
button a = [hsx||]
- getData f = map (\(Entity _ e) -> e) <$> runDb (selectList f []) :: IO [Token]
+ getData f o = map (\(Entity _ e) -> e) <$> runDb (selectList f o) :: IO [Token]
diff --git a/lib/Database/Schema.hs b/lib/Database/Schema.hs
index efc160b..0c21800 100644
--- a/lib/Database/Schema.hs
+++ b/lib/Database/Schema.hs
@@ -20,19 +20,19 @@ import Database.Persist.TH (mkEntityDefList, mkMigrate, mkPersist, persistLowerC
share [mkPersist sqlSettings, mkMigrate "migrateAll", mkEntityDefList "defs"] [persistLowerCase|
Visit sql=visits
- index Int sql=id
+ index Int sql=id
timestamp Int sql=timestamp
uuid String sql=uuid
deriving Eq Show
GuestbookEntry sql=guestbook
- index Int sql=id
+ index Int sql=id
timestamp Int sql=timestamp
name String sql=name
content String sql=content
parentId Int sql=parentId
deriving Eq Show
Snake sql=snake
- index Int sql=id
+ index Int sql=id
timestamp Int sql=timestamp
name String sql=name
score Int sql=score
@@ -40,12 +40,12 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll", mkEntityDefList "defs"] [p
fruits Int sql=fruits
deriving Eq Show
User sql=users
- index Int sql=id
+ index Int sql=id
name String sql=username
password String sql=password
deriving Eq Show
Token sql=valid_tokens
- index Int sql=id
+ index Int sql=id
token String sql=token
name String sql=username
deriving Eq Show