From b6f757c35e48f07207e4dc34fb757c09578101fe Mon Sep 17 00:00:00 2001 From: stuce-bot Date: Mon, 19 May 2025 12:06:39 +0200 Subject: [PATCH] fixed sanitisation a bit --- app/FileActions.hs | 52 +++++++++++++++++++++++++-------------------- app/Server.hs | 32 ++++++++++++++-------------- app/TodoListItem.hs | 23 +++++++++++++++++--- app/res/b | 10 ++++----- 4 files changed, 69 insertions(+), 48 deletions(-) diff --git a/app/FileActions.hs b/app/FileActions.hs index 51b1217..36e0b6c 100644 --- a/app/FileActions.hs +++ b/app/FileActions.hs @@ -7,34 +7,40 @@ module FileActions where import Data.Text qualified as T import Data.Text.IO qualified as TIO import System.Directory +import Text.Read qualified as TR import TodoListItem tempFile = "tempFile" --- TODO: add sanitisation using the todo item type ? --- TODO: sometimes the whitespace does not work as expected, find why and solve it -add folder file item = do - content <- TIO.readFile (folder <> file) - let result = content <> item - write folder file result -write folder file content = do - TIO.writeFile (folder <> tempFile) content +readF folder file = do + content <- readFile (folder <> file) + let itemsAsStrings = lines content + -- TODO: check if can simplify this step by making read work on list of items (i suppose it doesnt yet) + let itemsAsObjects = map TR.read itemsAsStrings :: [TodoListItem] + return itemsAsObjects +writeF folder file content = do + let result = show content + writeFile (folder <> tempFile) result renameFile (folder <> tempFile) (folder <> file) +appendF folder file item = do + content <- readF folder file + let result = content <> item -- TODO: check if more elegant solution exist (without needing a list for 1 item) + writeF folder file result + +delete :: FilePath -> FilePath -> TodoListItem -> IO () delete folder file item = do - content <- TIO.readFile (folder <> file) - let result = T.unlines $ filter (not . item) (T.lines content) - write folder file result + content <- readF folder file + let result = filter (/= item) content + writeF folder file result -check folder file item = do - content <- TIO.readFile (folder <> file) - let result = T.unlines $ map (swapIfMatch item) (T.lines content) - TIO.writeFile (folder <> tempFile) result - renameFile (folder <> tempFile) (folder <> file) - -swapIfMatch name strEncodedItem = if name == strEncodedItem then swapCheck strEncodedItem else strEncodedItem - -swapCheck text - | T.index text 1 == 'x' = "[ ] " <> T.drop 4 text - | T.index text 1 == ' ' = "[x] " <> T.drop 4 text - | otherwise = error "incorrectly formated element" +check :: FilePath -> FilePath -> TodoListItem -> IO () +check folder file name = do + content <- readF folder file + let result = map (swapIfMatch name) content + writeF folder file result + where + swapIfMatch name item = do + if item == name + then TodoListItem{name = TodoListItem.name item, done = not (TodoListItem.done item)} + else item diff --git a/app/Server.hs b/app/Server.hs index 19d4fdf..5e7c031 100644 --- a/app/Server.hs +++ b/app/Server.hs @@ -2,8 +2,6 @@ {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} --- For documentation purposes, I find it clearer to ignore eta reduce as it feels more natural for me in this context - module Server where import Data.ByteString.Lazy qualified as BL @@ -18,26 +16,24 @@ import Network.HTTP.Types import Network.HTTP.Types.URI (urlDecode) import Network.Wai import Network.Wai.Handler.Warp (run) +import TodoListItem application req respond = case (requestMethod req, pathInfo req) of ("GET", []) -> do - content <- TIO.readFile "./app/res/b" -- TODO: move that in fileActions + content <- FA.readF "./app/res/" "b" respond $ responseLBS status200 [("Content-Type", "text/html")] $ - TLE.encodeUtf8 $ - TL.fromStrict $ - simpleSite content + convert $ + simpleSite (show content) -- TODO: check if necessary to use text ("GET", ["edit"]) -> do - content <- TIO.readFile "./app/res/b" -- TODO: move that in fileActions + content <- FA.readF "./app/res/" "b" respond $ responseLBS status200 [("Content-Type", "text/html")] $ - TLE.encodeUtf8 $ - TL.fromStrict $ - editPage content + convert $ + editPage (show content) ("POST", ["edit"]) -> do -- TODO: refactor this shit, add sanitisation, make sure text ends with \n - putStrLn "overwriting list" body <- strictRequestBody req print body let args = L8.split '&' body @@ -50,11 +46,12 @@ application req respond = case pair of ("list=", t) -> do let text = TE.decodeUtf8 (urlDecode True (BL.toStrict t)) - FA.write "./app/res/" "b" text + let result = map read (lines $ T.unpack text) :: [TodoListItem] + FA.writeF "./app/res/" "b" result _ -> error "incorrect args" respond $ responseLBS status303 [(hLocation, "/")] "Redirecting..." ("POST", ["check", name]) -> do - FA.check "./app/res/" "b" name + FA.check "./app/res/" "b" (read $ T.unpack name) respond $ responseLBS status303 [(hLocation, "/")] "Redirecting..." -- TODO: refactor this using where better and creating meaningfull local functions ("POST", ["add"]) -> do @@ -70,7 +67,8 @@ application req respond = case pair of ("text=", t) -> do let text = TE.decodeUtf8 (urlDecode True (BL.toStrict t)) - FA.add "./app/res/" "b" text + let item = read (T.unpack text) :: TodoListItem + FA.appendF "./app/res/" "b" [item] _ -> error "incorrect args" respond $ responseLBS status303 [(hLocation, "/")] "Redirecting..." (method, array) -> do @@ -101,6 +99,7 @@ label for = wrapContentWithArgs "label" ("for=" <> for) textArea id rows cols = wrapContentWithArgs "textarea" ("id=\"" <> id <> "\" name=\"" <> id <> "\" rows=\"" <> rows <> "\" cols=\"" <> cols <> "\"") checkbox id name checked = checkboxPrimitive id name checked <> label id name +simpleSite :: String -> String simpleSite content = headHtml "en" "todo" <> h1 "Bienvenue" @@ -111,9 +110,8 @@ simpleSite content = <> rawEditButton <> tailHtml where - f content = T.concat $ map item (T.lines content) + f content = concatMap item (lines content) -item :: T.Text -> T.Text item rawLine = "
rawLine <> "\" method=\"POST\">
" newItemForm = "
" @@ -132,3 +130,5 @@ rawEditButton = link "/edit" "edit todo list" runServer = do run 3000 application + +convert = BL.fromStrict . TE.encodeUtf8 . T.pack diff --git a/app/TodoListItem.hs b/app/TodoListItem.hs index 250622f..c9562f2 100644 --- a/app/TodoListItem.hs +++ b/app/TodoListItem.hs @@ -4,12 +4,29 @@ data TodoListItem = TodoListItem { name :: String , done :: Bool } + deriving (Eq) instance Show TodoListItem where show (TodoListItem name done) = s done ++ " " ++ name ++ "\n" where - s True = "[x]" - s False = "[ ]" + s True = "x" + s False = "o" + showList = foldr ((.) . shows) id --- TODO: create a class to render items to html to make it easier to create everything for the website using the web primitives +instance Read TodoListItem where + readsPrec _ input = + let + parts = words input + in + case parts of + (status : nameParts) -> + let + name = unwords nameParts -- Join the remaining parts as the name + done = case status of + "x" -> True + "o" -> False + _ -> error "Invalid status" + in + [(TodoListItem name done, "")] + _ -> [] diff --git a/app/res/b b/app/res/b index 2253933..25ffe42 100644 --- a/app/res/b +++ b/app/res/b @@ -1,6 +1,4 @@ -[ ] Wake up -[ ] Eat -[ ] Sleep -[x] Repeat -[x] -[ ] dasd +o Wake up +o Eat +o Sleep +o Repeat