fixed sanitisation a bit
This commit is contained in:
parent
b07950f797
commit
b6f757c35e
4 changed files with 69 additions and 48 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 = "<form action=\"/check/" <> rawLine <> "\" method=\"POST\"><button type=\"submit\">" <> rawLine <> "</button></form>"
|
||||
|
||||
newItemForm = "<form action=\"/add\" method=\"post\"><input type=\"text\" name=\"text\" placeholder=\"[ ] add a new item\"><button type=\"submit\">Add</button></form>"
|
||||
|
|
@ -132,3 +130,5 @@ rawEditButton = link "/edit" "edit todo list"
|
|||
|
||||
runServer = do
|
||||
run 3000 application
|
||||
|
||||
convert = BL.fromStrict . TE.encodeUtf8 . T.pack
|
||||
|
|
|
|||
|
|
@ -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, "")]
|
||||
_ -> []
|
||||
|
|
|
|||
10
app/res/b
10
app/res/b
|
|
@ -1,6 +1,4 @@
|
|||
[ ] Wake up
|
||||
[ ] Eat
|
||||
[ ] Sleep
|
||||
[x] Repeat
|
||||
[x]
|
||||
[ ] dasd
|
||||
o Wake up
|
||||
o Eat
|
||||
o Sleep
|
||||
o Repeat
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue