Skip to content

Commit

Permalink
various api and database changes
Browse files Browse the repository at this point in the history
  • Loading branch information
@Mast3rwaf1z
Mast3rwaf1z committed Nov 6, 2024
1 parent cb96ba5 commit f97e1d2
Show file tree
Hide file tree
Showing 8 changed files with 106 additions and 83 deletions.
63 changes: 30 additions & 33 deletions app/Api/Api.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,7 @@

module Api.Api where

import Database.Database (getGuestbook, getVisits, runDb, uuidExists, validateToken)
import Database.Database (getGuestbook, getVisits, runDb, uuidExists, validateToken, AdminTable (getData))
import Pages.Projects.Brainfuck (code)
import qualified Tables as T (Credentials (Credentials, EmptyCredentials), GuestbookEntry (EmptyGuestbook, GuestbookEntry), LeaderboardEntry (EmptyLeaderboard, LeaderboardEntry))
import Utils (getDefault, unpackBS)
Expand All @@ -21,10 +21,10 @@ import Crypto.Random (getRandomBytes)
import Data.Aeson (Value (String), decode, encode)
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 (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, UserRid, VisitRid, GuestbookEntryRid, SnakeRid, TokenRid), GuestbookEntry (GuestbookEntry, guestbookEntryContent, guestbookEntryName, guestbookEntryParentId, guestbookEntryRid, guestbookEntryTimestamp), Snake (Snake), Token (Token, tokenToken), User (User, userName, userPassword), Visit (Visit))
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 Logger (info)
import Text.StringRandom (stringRandomIO)

Expand Down Expand Up @@ -61,7 +61,7 @@ messageResponse value = j2s [aesonQQ|{
apiMap :: [APIRoute]
apiMap = [
("POST", [
("/visits/new", \r -> do
("^/visits/new(/|)$", \r -> do
body <- getRequestBodyChunk r
result <- uuidExists $ unpackBS body
res <- if result then do
Expand All @@ -73,33 +73,29 @@ apiMap = [
return $ unpackBS body
return (status200, j2s [aesonQQ|{"uuid":#{res}}|], jsonHeaders)
),
("/login", \r -> do
("^/login(/|)$", \r -> do
body <- getRequestBodyChunk r
let credentials = getDefault T.EmptyCredentials (decode (fromStrict body) :: Maybe T.Credentials)
case credentials of
(T.Credentials username password) -> do
let pass = mkPassword $ pack password
rows <- map (\(Entity _ e) -> e) <$> (runDb $ selectList [UserName ==. username] [] :: IO [Entity User])
rows <- getData [UserName ==. username]
case rows of
[user] -> case checkPassword pass (PasswordHash $ pack (userPassword user)) of
PasswordCheckSuccess -> do
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
return $ unpack token
else return $ tokenToken $ head rows
return (status200, j2s [aesonQQ|{"token":#{response}}|], jsonHeaders)
token <- stringRandomIO "[0-9a-zA-Z]{4}-[0-9a-ZA-Z]{10}-[0-9a-zA-Z]{15}"
runDb $ insertEntity $ Token 0 (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)
_ -> return (status400, messageResponse "Error, Invalid request", jsonHeaders)
),
("/brainfuck", \r -> do
("^/brainfuck(/|)$", \r -> do
input <- getRequestBodyChunk r
let result = code $ unpackBS input
return (status200, result, [("Content-Disposition", "attachment; filename=\"brainfuck.c\"")])
),
("/editor/new", \r -> do
("^/editor/new(/|)$", \r -> do
filename <- getRequestBodyChunk r
editor_root <- getEditorRoot
files <- getDirectoryContents editor_root
Expand All @@ -113,27 +109,27 @@ apiMap = [
)
]),
("GET", [
("(/|)$", \_ -> do
("^(/|)$", \_ -> do
let apiData = map (\(method, routes) -> [aesonQQ|{
"method":#{method},
"routes":#{map fst routes}
}|]) apiMap
return (status200, j2s [aesonQQ|#{apiData}|], jsonHeaders)
),
("/visits/get", \_ -> do
("^/visits/get(/|)$", \_ -> do
visits <- show . length <$> getVisits
return (status200, j2s [aesonQQ|{"visits":#{visits}}|], jsonHeaders)
),
("/guestbook/get", \_ -> do
("^/guestbook/get(/|)$", \_ -> do
entries <- getGuestbook
return (status200, j2s [aesonQQ|{"entries":#{unpackBS $ toStrict $ encode $ show entries}}|], jsonHeaders)
),
("/editor/sidebar", \_ -> do
("^/editor/sidebar(/|)$", \_ -> do
editor_root <- getEditorRoot
files <- getDirectoryContents editor_root
return (status200, j2s [aesonQQ|#{files}|], jsonHeaders)
),
("/editor/content/.*", \r -> do
("^/editor/content/.*(/|)$", \r -> do
let filename = unpack $ last $ pathInfo r
editor_root <- getEditorRoot
handle <- openFile (editor_root ++ "/" ++ filename) ReadMode
Expand All @@ -142,7 +138,7 @@ apiMap = [
)
]),
("PUT", [
("/guestbook/add", \r -> do
("^/guestbook/add(/|)$", \r -> do
body <- getRequestBodyChunk r
let entry = getDefault T.EmptyGuestbook (decode (fromStrict body) :: Maybe T.GuestbookEntry)
case entry of
Expand All @@ -155,7 +151,7 @@ apiMap = [
runDb $ insertEntity $ GuestbookEntry 0 time name content parentId
return (status200, messageResponse "Success", jsonHeaders)
),
("/snake/add", \r -> do
("^/snake/add(/|)$", \r -> do
body <- getRequestBodyChunk r
let entry = getDefault T.EmptyLeaderboard (decode (fromStrict body) :: Maybe T.LeaderboardEntry)
case entry of
Expand All @@ -165,7 +161,7 @@ apiMap = [
runDb $ insertEntity $ Snake 0 time name score speed fruits
return (status200, messageResponse "Success", jsonHeaders)
),
("/editor/content/.*", \r -> do
("^/editor/content/.*(/|)$", \r -> do
body <- getRequestBodyChunk r
let content = unpackBS body
let filename = unpack $ last $ pathInfo r
Expand All @@ -177,14 +173,14 @@ apiMap = [
)
]),
("DELETE", [
("/editor/delete", \r -> do
("^/editor/delete(/|)$", \r -> do
body <- getRequestBodyChunk r
editor_root <- getEditorRoot
let filename = unpackBS body
removeFile $ editor_root ++ "/" ++ filename
return (status200, messageResponse "ok", jsonHeaders)
),
("/database/delete", \r -> do
("^/database/delete(/|)$", \r -> do
body <- getRequestBodyChunk r
let json = getDefault EmptyDatabaseDelete (decode (fromStrict body) :: Maybe DatabaseDelete)
let states = getStates r
Expand All @@ -195,15 +191,15 @@ apiMap = [
(DatabaseDelete table id) -> do
case table of
"visits" -> do
runDb $ deleteWhere [VisitRid ==. id]
runDb $ deleteWhere [VisitIndex ==. id]
"guestbook" -> do
runDb $ deleteWhere [GuestbookEntryRid ==. id]
runDb $ deleteWhere [GuestbookEntryIndex ==. id]
"snake" -> do
runDb $ deleteWhere [SnakeRid ==. id]
runDb $ deleteWhere [SnakeIndex ==. id]
"users" -> do
runDb $ deleteWhere [UserRid ==. id]
runDb $ deleteWhere [UserIndex ==. id]
"valid_tokens" -> do
runDb $ deleteWhere [TokenRid ==. id]
runDb $ deleteWhere [TokenIndex ==. id]
_ -> putStr "no table, doing nothing..."
return (status200, messageResponse "ok", jsonHeaders)
EmptyDatabaseDelete -> return (status400, messageResponse "Invalid JSON", jsonHeaders)
Expand All @@ -217,12 +213,13 @@ api :: Request -> APIResponse
api request = do
let method = unpackBS $ requestMethod request
let path = pathInfo request

case find (\(name, _) -> name == method) apiMap of
(Just (_, endpoints)) -> case find (checkEndpoint path) endpoints of
(Just (_, f)) -> f request
Nothing -> return (status400, messageResponse "Error, no endpoint found", defaultHeaders)
Nothing -> return (status400, messageResponse "Error, no endpoint found", defaultHeaders)
Nothing -> return (status400, messageResponse "Error, no endpoint found", jsonHeaders)
Nothing -> return (status400, messageResponse "Error, no endpoint found", jsonHeaders)
where
checkEndpoint path (regex, _) = case matchRegex (mkRegex ("api" ++ regex)) $ unpack (intercalate "/" path) of
checkEndpoint path (regex, _) = case matchRegex (mkRegex regex) $ "/" ++ unpack (intercalate "/" (drop 1 path)) of
Nothing -> False
_ -> True
18 changes: 11 additions & 7 deletions app/Footer.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,12 +2,16 @@ module Footer where

import IHP.HSX.QQ (hsx)
import Text.Blaze.Html (Html)
import State (getStates, loggedIn)
import State (getStates, loggedIn, accessToken)
import Network.Wai (Request)
import Database.Database (validateToken)

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||]
footer :: Request -> IO Html
footer request = if loggedIn (getStates request) then do
valid <- validateToken (accessToken (getStates request))
return $ if valid then [hsx|
<a href="/admin/logout">Log out</a>
|
<a href="/admin">Admin Panel</a>
|] else [hsx||]
else [hsx||]
2 changes: 1 addition & 1 deletion app/Index.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -52,7 +52,7 @@ page = do
fetch("/api/visits/new", {
method: "post",
body: getCookie("visitId")
}).then(res => res.json().then(data => setCookie("visitId="+data.uuid)))
}).then(res => res.json().then(data => setCookie("visitId="+data.uuid + ";max-age="+(24*60*60))))
</script>
|]

Expand Down
3 changes: 2 additions & 1 deletion app/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -101,7 +101,8 @@ app request respond = do
<meta content={description settings} property="og:description">
|] else [hsx||]

return $ serve (mconcat [result, image, text, desc, footer request])
footer' <- footer request
return $ serve (mconcat [result, image, text, desc, footer'])

logger request response
respond response
Expand Down
45 changes: 27 additions & 18 deletions app/Pages/Admin/Admin.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,23 +3,24 @@ 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.Schema (GuestbookEntry (GuestbookEntry, guestbookEntryRid), Snake (Snake, snakeRid), Token (Token, tokenRid), User (User, userRid), Visit (Visit, visitRid), defs)
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)
import Page (Page, PageSetting (Description, Route), getArgs)
import Text.Blaze.Html (Html)
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 (Entity(Entity), selectList, EntityNameDB (unEntityNameDB), getEntityDBName, FieldNameHS (unFieldNameHS), FieldDef (fieldHaskell), getEntityFields, (==.), PersistQueryWrite (deleteWhere))
import Database.Persist.MySQL (rawSql, mkColumns)
import Logger (warning)

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]
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
<br>
Expand All @@ -40,8 +41,6 @@ panel = do
</table>
|]
where
unpackEntity (Entity _ e) = e
mapUnpack = (map unpackEntity <$>)
th x = [hsx|<th>{x}</th>|]
row :: (String, [Int]) -> Html
row (name, values) = [hsx|
Expand Down Expand Up @@ -156,7 +155,7 @@ login = [hsx|
}).then(response => {
if (response.status == 200)
response.json().then(json => {
setCookie("accessToken="+json.token + ";path=/")
setCookie("accessToken="+json.token + ";max-age=" + (24*60*60*7) + ";path=/")
window.location.reload()
})
})
Expand All @@ -167,19 +166,29 @@ login = [hsx|
<button onclick="login()">Log in</button>
|]

logout :: Html
logout = [hsx|
<script>
deleteCookie("accessToken=")
</script>
You have successfully logged out!
|]
logout :: Request -> IO Html
logout request = do
let states = getStates request
if loggedIn states then do
let token = accessToken states
valid <- validateToken token
if valid then do
runDb $ deleteWhere [TokenToken ==. token]
else warning "Not a valid token"
else warning "Not logged in!"

return [hsx|
<script>
deleteCookie("accessToken=")
</script>
You have successfully logged out!
|]

page :: Request -> IO Html
page request = do
let states = getStates request
if last (pathInfo request) == "logout" then
return logout
logout request
else if loggedIn states then do
let token = accessToken states
valid <- validateToken token
Expand Down
Loading

0 comments on commit f97e1d2

Please sign in to comment.