completely redesigned admin page and storage

app/Api/Api.hs

@@ -2,7 +2,7 @@
 
 module Api.Api where
 
-import Database.Database (getGuestbook, getVisits, runDb, uuidExists)
+import Database.Database (getGuestbook, getVisits, runDb, uuidExists, 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)
 import Data.Text.Array (Array (ByteArray))
-import Database.Persist (Entity (Entity), Filter (Filter), FilterValue (FilterValue), PersistFilter (BackendSpecificFilter), insertEntity, selectList)
-import Database.Schema (EntityField (TokenName, UserName), GuestbookEntry (GuestbookEntry, guestbookEntryContent, guestbookEntryName, guestbookEntryParentId, guestbookEntryRid, 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, UserRid, VisitRid, GuestbookEntryRid, SnakeRid, TokenRid), GuestbookEntry (GuestbookEntry, guestbookEntryContent, guestbookEntryName, guestbookEntryParentId, guestbookEntryRid, guestbookEntryTimestamp), Snake (Snake), Token (Token, tokenToken), User (User, userName, userPassword), Visit (Visit))
 import Logger (info)
 import Text.StringRandom (stringRandomIO)
 
@@ -36,6 +36,8 @@ import Text.Regex (matchRegex, mkRegex)
 import System.IO (openFile, IOMode (ReadMode, WriteMode), hGetContents, hPutStr, hClose, writeFile)
 import System.Directory (getDirectoryContents, removeFile)
 import Settings (getEditorRoot)
+import Tables (DatabaseDelete(DatabaseDelete, EmptyDatabaseDelete))
+import State (getCookies, getStates, loggedIn, accessToken)
 
 type Header = (HeaderName, ByteString)
 type APIResponse = IO (Status, String, [Header])
@@ -77,11 +79,11 @@ apiMap = [
             case credentials of
                 (T.Credentials username password) -> do
                     let pass = mkPassword $ pack password
-                    rows <- map (\(Entity _ e) -> e) <$> (runDb $ selectList [Filter UserName (FilterValue username) (BackendSpecificFilter "LIKE")] [] :: IO [Entity User])
+                    rows <- map (\(Entity _ e) -> e) <$> (runDb $ selectList [UserName ==. username] [] :: IO [Entity User])
                     case rows of
                         [user] -> case checkPassword pass (PasswordHash $ pack (userPassword user)) of
                             PasswordCheckSuccess -> do
-                                rows <- map (\(Entity _ e) -> e) <$> (runDb $ selectList [Filter TokenName (FilterValue username) (BackendSpecificFilter "LIKE")] [] :: IO [Entity Token])
+                                rows <- map (\(Entity _ e) -> e) <$> (runDb $ selectList [TokenName ==. username] [] :: IO [Entity Token])
                                 response <- if null rows then 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
@@ -181,6 +183,32 @@ apiMap = [
             let filename = unpackBS body
             removeFile $ editor_root ++ "/" ++ filename
             return (status200, messageResponse "ok", jsonHeaders)
+        ),
+        ("/database/delete", \r -> do
+            body <- getRequestBodyChunk r
+            let json = getDefault EmptyDatabaseDelete (decode (fromStrict body) :: Maybe DatabaseDelete)
+            let states = getStates r
+
+            if loggedIn states then do 
+                validity <- validateToken (accessToken states)
+                if validity then case json of
+                    (DatabaseDelete table id) -> do
+                        case table of
+                            "visits" -> do
+                                runDb $ deleteWhere [VisitRid ==. id] :: IO ()
+                            "guestbook" -> do
+                                runDb $ deleteWhere [GuestbookEntryRid ==. id] :: IO ()
+                            "snake" -> do
+                                runDb $ deleteWhere [SnakeRid ==. id] :: IO ()
+                            "users" -> do
+                                runDb $ deleteWhere [UserRid ==. id] :: IO ()
+                            "valid_tokens" -> do
+                                runDb $ deleteWhere [TokenRid ==. id] :: IO ()
+                            _ -> putStr "no table, doing nothing..."
+                        return (status200, messageResponse "ok", jsonHeaders)
+                    EmptyDatabaseDelete -> return (status400, messageResponse "Invalid JSON", jsonHeaders)
+                else return (status400, messageResponse "Invalid token", jsonHeaders)
+            else return (status400, messageResponse "Not logged in", jsonHeaders)
         )
     ])
     ]

app/Footer.hs

@@ -2,9 +2,12 @@ module Footer where
 
 import IHP.HSX.QQ (hsx)
 import Text.Blaze.Html (Html)
+import State (getStates, loggedIn)
+import Network.Wai (Request)
 
-footer :: Html
-footer = [hsx|
-    <div>
-    </div>
-|]
+footer :: Request -> Html
+footer request = if loggedIn (getStates request) then [hsx|
+    <a href="/admin/logout">Log out</a>
+    |
+    <a href="/admin">Admin Panel</a>
+|] else [hsx||]

app/Layout.hs

@@ -5,6 +5,7 @@ import Text.Blaze.Html (Html)
 
 import Footer (footer)
 import Header (header)
+import Network.Wai (Request)
 
 layout :: Html -> Html
 layout content = [hsx|
@@ -32,6 +33,5 @@ layout content = [hsx|
                 <hr>
             </div>
         </body>
-        {footer}
     </html>
 |]

app/Main.hs

@@ -43,7 +43,8 @@ import Settings (getCliState, getMigrate, getPort)
 import System.Environment (getArgs)
 import Text.Regex (Regex, matchRegex, mkRegex)
 import Utils (unpackBS)
-import State (getStates)
+import State (getStates, getCookies)
+import Footer (footer)
 
 serve :: Html -> Response
 serve content = responseBuilder status200 [("Content-Type", "text/html")] $ copyByteString (fromString (renderHtml content))
@@ -74,6 +75,8 @@ app request respond = do
     let xs = map unpack $ pathInfo request
     let x = if null xs then "" else head xs
     let args = "/" ++ intercalate "/" xs
+    print $ getStates request
+    print $ getCookies request
     response <- if x == "static" then do
         -- If the requested content is a file
         serveFile $ intercalate "/" xs
@@ -98,7 +101,7 @@ app request respond = do
             <meta content={description settings} property="og:description">
         |] else [hsx||]
 
-        return $ serve (mconcat [result, image, text, desc])
+        return $ serve (mconcat [result, image, text, desc, footer request])
 
     logger request response
     respond response

app/Pages/Admin/Admin.hs

@@ -1,20 +1,142 @@
 module Pages.Admin.Admin where
 
 import CodeBlock (codeBlock)
-import Data.Text (Text)
-import Database.Database (getGuestbookEntries, getLeaderboard, getTokens, getUsers, getVisits, prettyPrintSchema, tokenToUsername, validateToken)
-import Database.Schema (GuestbookEntry (GuestbookEntry), Snake (Snake), Token (Token), User (User), Visit (Visit))
+import Data.Text (Text, unpack, pack)
+import Database.Database (getGuestbookEntries, getLeaderboard, getTokens, getUsers, getVisits, prettyPrintSchema, tokenToUsername, validateToken, runDb, AdminTable (button, toList, getData))
+import Database.Schema (GuestbookEntry (GuestbookEntry, guestbookEntryRid), Snake (Snake, snakeRid), Token (Token, tokenRid), User (User, userRid), Visit (Visit, visitRid), defs)
 import IHP.HSX.QQ (hsx)
 import Layout (layout)
 import Page (Page, PageSetting (Description, Route), getArgs)
 import Text.Blaze.Html (Html)
-import Network.Wai (Request)
+import Network.Wai (Request (pathInfo))
 import State (getStates, loggedIn, accessToken)
+import Database.Persist (Entity(Entity), selectList, EntityNameDB (unEntityNameDB), getEntityDBName, FieldNameHS (unFieldNameHS), FieldDef (fieldHaskell), getEntityFields)
+import Database.Persist.MySQL (rawSql, mkColumns)
 
-panel :: Html
-panel = [hsx|
-    Here are actions when logged in
-|]
+panel :: IO Html
+panel = do 
+    visits <- mapUnpack $ runDb (selectList [] []) :: IO [Visit]
+    guestbook <- mapUnpack $ runDb (selectList [] []) :: IO [GuestbookEntry]
+    snake <- mapUnpack $ runDb (selectList [] []) :: IO [Snake]
+    users <- mapUnpack $ runDb (selectList [] []) :: IO [User]
+    valid_tokens <- mapUnpack $ runDb (selectList [] []) :: IO [Token]
+    return [hsx|
+        Here are actions when logged in
+        <br>
+        Database stats:<br>
+        <table class="common-table">
+            <tr>
+                <th class="common-table-element">name</th>
+                <th class="common-table-element">length</th>
+                <th class="common-table-element"></th>
+            </tr>
+            {mconcat $ map row [
+                ("visits", [length visits]), 
+                ("guestbook", [length guestbook]), 
+                ("snake", [length snake]),
+                ("users", [length users]),
+                ("valid_tokens", [length valid_tokens])
+            ]}
+        </table>
+    |]
+    where
+        unpackEntity (Entity _ e) = e
+        mapUnpack = (map unpackEntity <$>)
+        th x = [hsx|<th>{x}</th>|]
+        row :: (String, [Int]) -> Html
+        row (name, values) = [hsx|
+            <tr>
+                <th class="common-table-element">
+                    {name}
+                </th>
+                {mconcat $ map th values}
+                <th><a href={"/admin/browse/"++name}>Browse</a></th>
+            </tr>
+        |]
+
+browse :: String -> IO Html
+browse table = do 
+    tableData <- getTableData table
+    let columnNames = getColumnNames table
+    return [hsx|
+        {table} contains:<br>
+        <script>
+            function delete_row(id) {
+                var table = id.split("::")[0]
+                var rid = id.split("::")[1]
+                fetch("/api/database/delete", {
+                    method:"DELETE",
+                    body:JSON.stringify({
+                        table:table,
+                        id:parseInt(rid)
+                    })
+                }).then(response => {
+                    if (response.status == 200)
+                        window.location.reload()
+                    else alert("Failed to delete row, status: "+ response.status)
+                })
+            }
+        </script>
+        <table class="common-table">
+            {row (columnNames, empty)}
+            {mconcat $ map row tableData}
+        </table><br>
+
+        Insert new row below:
+        <div id="new-row">
+
+        </div>
+    |]
+    where
+        getTableData :: String -> IO [([String], Html)]
+        getTableData "visits" = do
+            tableData <- getData [] :: IO [Visit]
+            let columnNames = getColumnNames "visits"
+            return $ zip (map toList tableData) (map button tableData)
+        getTableData "guestbook" = do
+            tableData <- getData [] :: IO [GuestbookEntry]
+            let columnNames = getColumnNames "guestbook"
+            return $ zip (map toList tableData) (map button tableData)
+        getTableData "snake" = do
+            tableData <- getData [] :: IO [Snake]
+            let columnNames = getColumnNames "snake"
+            return $ zip (map toList tableData) (map button tableData)
+        getTableData "users" = do 
+            tableData <- getData [] :: IO [User]
+            let columnNames = getColumnNames "users"
+            return $ zip (map toList tableData) (map button tableData)
+        getTableData "valid_tokens" = do
+            tableData <- getData [] :: IO [Token]
+            let columnNames = getColumnNames "valid_tokens"
+            return $ zip (map toList tableData) (map button tableData)
+        getTableData _ = do
+            return [(["Error!"], [hsx||]), (["No such table"], [hsx||])]
+
+        getColumnNames :: String -> [String]
+        getColumnNames name = map (unpack . unFieldNameHS . fieldHaskell) $ getEntityFields $ head $ filter ((==pack name) . unEntityNameDB . getEntityDBName) defs
+
+        row :: ([String], Html) -> Html
+        row (xs, button) = [hsx|
+            <tr>
+                {_row xs}
+                <th class="common-table-element">
+                    {button}
+                </th>
+            </tr>
+        |]
+        _row :: [String] -> Html
+        _row (x:xs) = [hsx|
+            <th class="common-table-element">
+                {x}
+            </th>
+            {_row xs}
+        |]
+        _row [] = [hsx||]
+        empty = [hsx||]
+
+route :: [String] -> IO Html
+route [_, "browse", table] = browse table
+route _ = panel
 
 login :: Html
 login = [hsx|
@@ -34,7 +156,7 @@ login = [hsx|
             }).then(response => {
                 if (response.status == 200)
                     response.json().then(json => {
-                        setCookie("accessToken="+json.token)
+                        setCookie("accessToken="+json.token + ";path=/")
                         window.location.reload()
                     })
             })
@@ -45,14 +167,24 @@ login = [hsx|
     <button onclick="login()">Log in</button>
 |]
 
+logout :: Html
+logout = [hsx|
+    <script>
+        deleteCookie("accessToken=")
+    </script>
+    You have successfully logged out!
+|]
+
 page :: Request -> IO Html
 page request = do
     let states = getStates request
-    if loggedIn states then do
+    if last (pathInfo request) == "logout" then
+        return logout
+    else if loggedIn states then do
         let token = accessToken states
         valid <- validateToken token
         if valid then
-            return panel
+            route (map unpack $ pathInfo request)
         else
             return login
     else

app/Pages/Projects/Snake.hs

@@ -91,7 +91,7 @@ leaderboardField value = [hsx|
 
 leaderboardEntry :: Snake -> Html
 leaderboardEntry (Snake id timestamp name score speed fruits) = [hsx|
-    <tr>
+    <tr class="common-table-element">
         {mconcat $ map leaderboardField [name, show timestamp, show score, show speed, show fruits]}
     </tr>
 |]
@@ -100,13 +100,13 @@ page :: IO Html
 page = do
     l <- getLeaderboard
     return [hsx|
-        <table>
+        <table class="common-table">
             <tr>
-                <th>Name</th>
-                <th>Time</th>
-                <th>Score</th>
-                <th>Speed</th>
-                <th>Fruits</th>
+                <th class="common-table-element">Name</th>
+                <th class="common-table-element">Time</th>
+                <th class="common-table-element">Score</th>
+                <th class="common-table-element">Speed</th>
+                <th class="common-table-element">Fruits</th>
             </tr>
             {mconcat $ map leaderboardEntry l}
         </table>

app/Pages/Sources/Repo.hs

@@ -50,17 +50,17 @@ repo = do
     return [hsx|
         <hr>
         Commit History:<br>
-        <table style="display:inline-block;border:1px solid white; padding:5px; overflow-y: scroll; max-height: 500px;">
+        <table class="common-table">
         {result}
         </table>
     |]
     where
         handleCommits ((CommitData url (Commit message (Author date))) : xs) = [hsx|
             <tr>
-                <th style="width:500px; height: 50px;">
+                <th class="common-table-element">
                     <a href={url}>{message}</a>
                 </th>
-                <th style="width:100px; height: 50px;">
+                <th class="common-table-element">
                     {date}
                 </th>
             </tr>