diff --git a/app/FileActions.hs b/app/FileActions.hs index 67c8666..36e0b6c 100644 --- a/app/FileActions.hs +++ b/app/FileActions.hs @@ -16,7 +16,7 @@ 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 read itemsAsStrings :: [TodoListItem] + let itemsAsObjects = map TR.read itemsAsStrings :: [TodoListItem] return itemsAsObjects writeF folder file content = do let result = show content diff --git a/app/HtmlPrimitives.hs b/app/HtmlPrimitives.hs index 0ce2fde..f4525ff 100644 --- a/app/HtmlPrimitives.hs +++ b/app/HtmlPrimitives.hs @@ -1,62 +1,38 @@ {-# LANGUAGE OverloadedStrings #-} -module HtmlPrimitives (mainPage, editPage) where +module HtmlPrimitives where --- NOTE: this looks like shit, but that's what happens when u dont use library and u bad --- TODO: check if compiler does in fact inline this mess as it has no buisness beeing computed more than once pro build - -{-# INLINE mainPage #-} -mainPage content = - html "en" "todo" $ - h1 "Todo Liste" - <> h2 "Stuce" - <> f content - <> newItemForm - <> rawEditButton - where - f content = concatMap item (lines content) - newItemForm = form "action=\"/add\" method=\"post\"> br <> editTextArea content <> br <> editButton - editLabel = label "list" "Edit the todo list" - editTextArea = textArea "list" "30" "33" - editButton = button "type=\"submit\"" "submit" +import Control.Monad.RWS (lift) openingTag tag = "<" <> tag <> ">" closingTag tag = " tag <> ">" - wrapContent tag content = openingTag tag <> content <> closingTag tag -wrapContentWithArgs tag arg content = openingTag (tag <> " " <> arg) <> content <> closingTag tag -singleWrap = closingTag +wrapContentWithArgs tag arg content = openingTag (tag <> arg) <> content <> closingTag tag +singleWrap content = "<" <> content <> "/>" -br = "
" +docType = "" h1 = wrapContent "h1" h2 = wrapContent "h2" h3 = wrapContent "h3" -link href = wrapContentWithArgs "a" ("href=\"" <> href <> "\"") +link = wrapContent "a" +li = wrapContent "li" p = wrapContent "p" -button = wrapContentWithArgs "button" -form = wrapContentWithArgs "form" -label for = wrapContentWithArgs "label" ("for=" <> for) -textArea id rows cols = wrapContentWithArgs "textarea" ("id=\"" <> id <> "\" name=\"" <> id <> "\" rows=\"" <> rows <> "\" cols=\"" <> cols <> "\"") + +checkboxPrimitive id name True = singleWrap $ "input type='checkbox' id=" <> id <> " name=" <> name <> " checked" +checkboxPrimitive id name False = singleWrap $ "input type='checkbox' id=" <> id <> " name=" <> name + +label for = wrapContentWithArgs "label " ("for=" <> for) + checkbox id name checked = checkboxPrimitive id name checked <> label id name - where - checkboxPrimitive id name True = singleWrap $ "input type='checkbox' id=" <> id <> " name=" <> name <> " checked" - checkboxPrimitive id name False = singleWrap $ "input type='checkbox' id=" <> id <> " name=" <> name -item rawLine = "
rawLine <> "\" method=\"POST\">
" +-- | Takes a raw line as in untouched from the file +item rawLine = "
rawLine <> "\" method=\"POST\">
" -html lang title content = headHtml lang title <> content <> tailHtml - where - headHtml lang title = - " lang - <> "\">" - <> title - <> "" - tailHtml = "" +path = "./app/res/b" + +simpleSite fileContent = + docType + <> h1 "Bienvenue sur la todo liste" + <> p "this website is a simple example of how haskell can quickly become a great tool to write websites fast" + +ul content = wrapContent "ul" $ concatMap (wrapContent "li") content diff --git a/app/Server.hs b/app/Server.hs index 1b5a46b..5e7c031 100644 --- a/app/Server.hs +++ b/app/Server.hs @@ -12,17 +12,12 @@ import Data.Text.IO qualified as TIO import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding qualified as TLE import FileActions qualified as FA -import HtmlPrimitives import Network.HTTP.Types import Network.HTTP.Types.URI (urlDecode) import Network.Wai import Network.Wai.Handler.Warp (run) import TodoListItem --- TODO: make every http generator in another file and make it cleaner --- TODO: make the case statement readable and use where more --- TODO: make better use of reads or readMaybe or watever to not just make it crash but cancel bad inputs by default - application req respond = case (requestMethod req, pathInfo req) of ("GET", []) -> do @@ -30,7 +25,7 @@ application req respond = respond $ responseLBS status200 [("Content-Type", "text/html")] $ convert $ - mainPage (show content) -- TODO: check if necessary to use text + simpleSite (show content) -- TODO: check if necessary to use text ("GET", ["edit"]) -> do content <- FA.readF "./app/res/" "b" respond $ @@ -38,7 +33,7 @@ application req respond = convert $ editPage (show content) ("POST", ["edit"]) -> do - -- TODO: refactor this shit + -- TODO: refactor this shit, add sanitisation, make sure text ends with \n body <- strictRequestBody req print body let args = L8.split '&' body @@ -51,7 +46,6 @@ application req respond = case pair of ("list=", t) -> do let text = TE.decodeUtf8 (urlDecode True (BL.toStrict t)) - print text let result = map read (lines $ T.unpack text) :: [TodoListItem] FA.writeF "./app/res/" "b" result _ -> error "incorrect args" @@ -82,6 +76,58 @@ application req respond = splitKeyValue bs = case L8.break (== '=') bs of (key, rest) -> (key, L8.drop 1 rest) +openingTag tag = "<" <> tag <> ">" +closingTag tag = " tag <> ">" +wrapContent tag content = openingTag tag <> content <> closingTag tag +wrapContentWithArgs tag arg content = openingTag (tag <> " " <> arg) <> content <> closingTag tag +singleWrap content = "<" <> content <> "/>" + +headHtml lang title = " lang <> "\">" <> title <> "" +tailHtml = "" +br = "
" +h1 = wrapContent "h1" +h2 = wrapContent "h2" +h3 = wrapContent "h3" +link href = wrapContentWithArgs "a" ("href=\"" <> href <> "\"") +li = wrapContent "li" +p = wrapContent "p" + +checkboxPrimitive id name True = singleWrap $ "input type='checkbox' id=" <> id <> " name=" <> name <> " checked" +checkboxPrimitive id name False = singleWrap $ "input type='checkbox' id=" <> id <> " name=" <> name + +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" + <> h2 "Site exemple" + <> p "this website is a simple example of how haskell can quickly become a great tool to write websites fast" + <> f content + <> newItemForm + <> rawEditButton + <> tailHtml + where + f content = concatMap item (lines content) + +item rawLine = "
rawLine <> "\" method=\"POST\">
" + +newItemForm = "
" + +editForm content = editLabel <> br <> editTextArea content <> br <> editButton + where + editLabel = label "list" "Edit the todo list" + editTextArea = textArea "list" "30" "33" + editButton = wrapContentWithArgs "button" "type=\"submit\"" "submit" + +editPage content = + headHtml "en" "edit" + <> wrapContentWithArgs "form" "action=\"/edit\" method=\"post\"" (editForm content) + <> tailHtml +rawEditButton = link "/edit" "edit todo list" + runServer = do run 3000 application diff --git a/app/TodoListItem.hs b/app/TodoListItem.hs index 5e1fab3..c9562f2 100644 --- a/app/TodoListItem.hs +++ b/app/TodoListItem.hs @@ -15,15 +15,18 @@ instance Show TodoListItem where showList = foldr ((.) . shows) id instance Read TodoListItem where - readsPrec _ input = do - let (item, rest) = break (== '\n') input - let (d, n) = splitAt 2 item + readsPrec _ input = let - done = case d of - "x " -> True - "o " -> False - _ -> error "Invalid status" - name = case n of - "" -> error "empty name" - something -> filter (/= '\r') something - [(TodoListItem name done, rest)] + 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, "")] + _ -> []