rewrote api (#7)

* rewrote api

* changed api endpoints respond with json

app/Api/Api.hs

@@ -15,13 +15,13 @@ import Data.Time.Clock.POSIX (getPOSIXTime)
 import Data.UUID.V4 (nextRandom)
 import Data.UUID (toString)
 
-import Network.Wai (getRequestBodyChunk, Request)
+import Network.Wai (getRequestBodyChunk, Request (requestMethod, pathInfo))
 import Network.HTTP.Types.Status (Status, status404, status200, status400)
 
 import Data.Aeson (encode, decode, Value (String))
 import Data.ByteString.Lazy (fromStrict, toStrict)
 import Data.Password.Bcrypt (PasswordCheck(PasswordCheckSuccess, PasswordCheckFail), mkPassword, checkPassword, PasswordHash (PasswordHash))
-import Data.Text (pack, unpack)
+import Data.Text (pack, unpack, intercalate)
 import Crypto.Random (getRandomBytes)
 import Data.Text.Array (Array(ByteArray))
 import Text.StringRandom (stringRandomIO)
@@ -31,97 +31,117 @@ import Database.Persist (selectList, Entity (Entity), insertEntity, Filter (Filt
 
 import Network.HTTP.Types (HeaderName)
 import Data.ByteString.UTF8 (ByteString)
-import Data.Aeson.QQ.Simple (aesonQQ)
+import Data.Aeson.QQ (aesonQQ)
+import Data.List (find)
+import Text.Regex (matchRegex, mkRegex)
 
 type Header = (HeaderName, ByteString)
 type APIResponse = IO (Status, String, [Header])
+type APIEndpoint = (String, Request -> APIResponse)
+type APIRoute = (String, [APIEndpoint])
 
 j2s :: Value -> String
 j2s = unpackBS . toStrict .encode
 
 defaultHeaders :: [Header]
 defaultHeaders = [("Content-Type", "text/plain")]
 
+jsonHeaders :: [Header]
+jsonHeaders = [("Content-Type", "application/json")]
+
 messageResponse :: String -> String
 messageResponse value = j2s [aesonQQ|{
-    "message":"#{value}"
+    "message":#{value}
 }|]
 
-
-handleGuestbookEntry :: T.GuestbookEntry -> APIResponse
-handleGuestbookEntry (T.GuestbookEntry "" _ _) = return (status400, "Error, name cannot be empty", defaultHeaders)
-handleGuestbookEntry (T.GuestbookEntry _ "" _) = return (status400, "Error, content cannot be empty", defaultHeaders)
-handleGuestbookEntry (T.GuestbookEntry name content parentId) = do
-    time <- fmap round getPOSIXTime :: IO Int
-    runDb $ insertEntity $ GuestbookEntry 0 time name content parentId
-    return (status200, messageResponse "Success" , defaultHeaders)
-
-handleLeaderboardEntry :: T.LeaderboardEntry -> APIResponse
-handleLeaderboardEntry (T.LeaderboardEntry name score speed fruits) = do
-    time <- fmap round getPOSIXTime :: IO Int
-    runDb $ insertEntity $ Snake 0 time name score speed fruits
-    return (status200, messageResponse "Success", defaultHeaders)
-handleLeaderboardEntry T.EmptyLeaderboard = return (status400, messageResponse "Error", defaultHeaders)
-
-handleLogin :: T.Credentials -> APIResponse
-handleLogin (T.Credentials username password) = do
-    let pass = mkPassword $ pack password
-    rows <- map (\(Entity _ e) -> e) <$> (runDb $ selectList [Filter UserUserName (FilterValue username) (BackendSpecificFilter "LIKE")] [] :: IO [Entity User])
-    case rows of
-        [user] -> case checkPassword pass (PasswordHash $ pack (userUserPassword user)) of
-            PasswordCheckSuccess -> do
-                rows <- map (\(Entity _ e) -> e) <$> (runDb $ selectList [Filter TokenTokenName (FilterValue username) (BackendSpecificFilter "LIKE")] [] :: IO [Entity Token])
-                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 (status200, unpack token, defaultHeaders)
-                else do
-                    let row = head rows
-                    return (status200, tokenTokenToken row, defaultHeaders)
-                    where
-            PasswordCheckFail -> return (status400, messageResponse "Wrong username or password", defaultHeaders)
-        _ -> return (status400, messageResponse "Error, no user exists" , defaultHeaders)
-handleLogin _ = return (status400, messageResponse "Invalid request", defaultHeaders)
-
-api :: [String] -> Request -> APIResponse
-api ["visits", "new"] request = do
-    body <- getRequestBodyChunk request
-    result <- uuidExists (unpackBS body)
-    if result then do
-        time <- fmap round getPOSIXTime :: IO Int
-        uuid <- nextRandom
-        runDb $ insertEntity $ Visit 0 time $ toString uuid
-        info "Inserted into db"
-        return (status200, toString uuid, defaultHeaders)
-    else
-        return (status200, unpackBS body, defaultHeaders)
-api ["visits", "get"] request = do
-    visits <- show . length <$> getVisits
-    return (status200, visits, [])
-api ["guestbook", "add"] request = do
-    body <- getRequestBodyChunk request
-    let entry = getDefault T.EmptyGuestbook (decode (fromStrict body) :: Maybe T.GuestbookEntry)
-    handleGuestbookEntry entry
-api ["guestbook", "get"] request = do
-    body <- getRequestBodyChunk request
-    entries <- getGuestbook
-    return (status200, unpackBS $ toStrict $ encode $ show entries, defaultHeaders)
-api ["snake", "add"] request = do
-    body <- getRequestBodyChunk request
-    let entry = getDefault T.EmptyLeaderboard (decode (fromStrict body) :: Maybe T.LeaderboardEntry)
-    handleLeaderboardEntry entry
-api ["admin", "login"] request = do
-    body <- getRequestBodyChunk request
-    let credentials = getDefault T.EmptyCredentials (decode (fromStrict body) :: Maybe T.Credentials)
-    handleLogin credentials
-api ["hello"] _ = do
-    return (status200, j2s [aesonQQ|{
-        "message":"Hello World!"
-    }|], defaultHeaders)
-api ["brainfuck"] request = do
-    input <- getRequestBodyChunk request
-    let result = code $ unpackBS input
-    return (status200, result, [("Content-Disposition", "attachment; filename=\"brainfuck.c\"")])
-
-api xs request = do
-    return (status404, messageResponse "Endpoint does not exist", defaultHeaders)
+apiMap :: [APIRoute]
+apiMap = [
+    ("POST", [
+        ("/visits/new", \r -> do
+            body <- getRequestBodyChunk r
+            result <- uuidExists $ unpackBS body
+            res <- if result then do
+                time <- fmap round getPOSIXTime :: IO Int
+                uuid <- nextRandom
+                runDb $ insertEntity $ Visit 0 time $ toString uuid
+                return $ toString uuid
+            else
+                return $ unpackBS body
+            return (status200, j2s [aesonQQ|{"uuid":#{res}}|], jsonHeaders)
+        ),
+        ("/admin/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 [Filter UserUserName (FilterValue username) (BackendSpecificFilter "LIKE")] [] :: IO [Entity User])
+                    case rows of
+                        [user] -> case checkPassword pass (PasswordHash $ pack (userUserPassword user)) of
+                            PasswordCheckSuccess -> do
+                                rows <- map (\(Entity _ e) -> e) <$> (runDb $ selectList [Filter TokenTokenName (FilterValue username) (BackendSpecificFilter "LIKE")] [] :: 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 $ tokenTokenToken $ head rows
+                                return (status200, j2s [aesonQQ|{"token":#{response}}|], 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
+            input <- getRequestBodyChunk r
+            let result = code $ unpackBS input
+            return (status200, result, [("Content-Disposition", "attachment; filename=\"brainfuck.c\"")])
+        )
+    ]),
+    ("GET", [
+        ("/visits/get", \_ -> do
+            visits <- show . length <$> getVisits
+            return (status200, j2s [aesonQQ|{"visits":#{visits}}|], jsonHeaders)
+        ),
+        ("/guestbook/get", \_ -> do
+            entries <- getGuestbook
+            return (status200, j2s [aesonQQ|{"entries":#{unpackBS $ toStrict $ encode $ show entries}}|], jsonHeaders)
+        )
+    ]),
+    ("PUT", [
+        ("/guestbook/add", \r -> do
+            body <- getRequestBodyChunk r
+            let entry = getDefault T.EmptyGuestbook (decode (fromStrict body) :: Maybe T.GuestbookEntry)
+            case entry of
+                (T.GuestbookEntry "" _ _) -> return (status400, messageResponse "Error, name cannot be empty", jsonHeaders)
+                (T.GuestbookEntry _ "" _) -> 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
+                    return (status200, messageResponse "Success", jsonHeaders)
+        ),
+        ("/snake/add", \r -> do
+            body <- getRequestBodyChunk r
+            let entry = getDefault T.EmptyLeaderboard (decode (fromStrict body) :: Maybe T.LeaderboardEntry)
+            case entry of
+                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
+                    return (status200, messageResponse "Success", jsonHeaders)
+        )
+    ]),
+    ("DELETE", [
+
+    ])
+    ]
+
+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 (\(regex, _) -> (case matchRegex (mkRegex ("api" ++ regex)) $ unpack (intercalate "/" path) of
+            Nothing -> False
+            _ -> True)) endpoints of
+            (Just (_, f)) -> f request
+            Nothing -> return (status400, messageResponse "Error, no endpoint found", defaultHeaders)
+        Nothing -> return (status400, messageResponse "Error, no endpoint found", defaultHeaders)

app/Index.hs

@@ -53,7 +53,7 @@ page = do
         fetch("/api/visits/new", {
             method: "post",
             body: getCookie("visitId")
-        }).then(res => res.text().then(uuid => setCookie("visitId="+uuid)))
+        }).then(res => res.json().then(data => setCookie("visitId="+data.uuid)))
     </script>
 |]
 

app/Main.hs

@@ -11,7 +11,7 @@ import Data.List (intercalate, find)
 
 import System.Directory (doesFileExist)
 
-import Network.Wai (responseBuilder, responseFile, Request (queryString))
+import Network.Wai (responseBuilder, responseFile, Request (queryString), responseLBS)
 import Network.Wai.Handler.Warp (run)
 import Network.Wai.Internal (Response(ResponseBuilder, ResponseFile), Request, pathInfo, requestMethod)
 import Network.HTTP.Types (statusCode, status200, status404, Status, Query, HeaderName)
@@ -31,7 +31,7 @@ import Database.Database (doMigration)
 import Utils (unpackBS)
 import Settings (getPort, getCliState, getMigrate)
 import Logger (logger, tableify, info, warning)
-import Api.Api (api)
+import Api.Api (api, j2s)
 import Control.Concurrent (forkIO, ThreadId)
 import Repl (repl)
 import System.Environment (getArgs)
@@ -41,6 +41,8 @@ import Pages.Pages (findPage)
 import Data.List.Split (splitOn)
 import Control.Monad (when)
 import Page (embedText, embedImage, description)
+import Data.Aeson.QQ (aesonQQ)
+import Data.Aeson (encode)
 
 
 serve :: Html -> Response
@@ -66,7 +68,7 @@ serveFile path = do
         return $ responseFile status200 [autoContentType path] path Nothing
     else do
         warning "No file found!"
-        return $ responseBuilder status404 [("Content-Type", "text/json")] $ copyByteString "{\"error\":\"Error: file not found!\"}"
+        return $ responseLBS status404 [("Content-Type", "text/json")] $ encode [aesonQQ|{"error":"Error, file not found"}|]
 
 app :: Request -> (Response -> IO b)  -> IO b
 app request respond = do
@@ -80,7 +82,7 @@ app request respond = do
         serveFile "static/favicon.ico"
 
     else if x == "api" then do -- If the request is to the API
-        (status, value, headers) <- api (drop 1 xs) request
+        (status, value, headers) <- api request
         return $ responseBuilder status headers $ copyByteString (fromString value)
 
     else do -- If the content is to the HTML Frontend

app/Pages/Admin/Admin.hs

@@ -167,14 +167,14 @@ page x = do
                         username:username,
                         password:password
                     })
-                }).then(response => response.text().then(text => {
+                }).then(response => response.json().then(data => {
                     if(response.ok) {
-                        setCookie("adminToken="+text+";path=/")
-                        window.location.href = "/admin/summary/"+text
+                        setCookie("adminToken="+data.token+";path=/")
+                        window.location.href = "/admin/summary/"+data.token
                     }
                     else {
                         var error_display = document.getElementById("error_display")
-                        error_display.innerHTML = text
+                        error_display.innerHTML = data.message
                     }
                 }))
             }

app/Pages/Guestbook/Guestbook.hs

@@ -76,7 +76,7 @@ page = do
                 var name = document.getElementById("guestbook-name::"+id).value
                 console.log(id)
                 fetch("/api/guestbook/add", {
-                    method:"POST",
+                    method:"PUT",
                     body: JSON.stringify({
                         name: name,
                         content: text,
@@ -86,8 +86,8 @@ page = do
                     if(response.status == 200){
                         window.location.reload()
                     }
-                    else response.text().then(text => {
-                        alert(response.status + "\n" + text)
+                    else response.json().then(data => {
+                        alert(response.status + "\n" + data.message)
                     })
                 })
             }

flake.nix

@@ -49,7 +49,7 @@
                 installPhase = ''
                     mkdir -p $out/bin
                     ln -s ${packages.${system}.homepage}/bin/homepage $out/bin/homepage
-                    ln -s ${packages.${system}.homepage}/bin/cli $out/bin/cli
+                    ln -s ${packages.${system}.homepage}/bin/repl-homepage $out/bin/repl-homepage
                     cp -r $src/static $out
                 '';
             };

static/projects/snake.js

@@ -90,7 +90,7 @@ async function launchGame() {
 
         if(name != "") {
             fetch("/api/snake/add", {
-                method: "post",
+                method: "PUT",
                 body: JSON.stringify({
                     name: document.getElementById("player-name").value,
                     timestamp: time,