Stuce/todo
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

initial commit

Browse source
This commit is contained in:
stuce-bot 2025-05-13 20:21:30 +02:00
commit 70d3db13c7
17 changed files with 1109 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

36
app/ArgParser.hs Normal file
View file

@ -0,0 +1,36 @@
module ArgParser where
import Options.Applicative
data Args = Args
{ argAdd :: Maybe String
, argDelete :: Maybe String
, argCheck :: Maybe String
, argTui :: Bool
}
args :: Parser Args
args =
Args
<$> optional
( strOption
( long "add"
<> short 'a'
<> help "add a new item"
)
)
<*> optional
( strOption
( long "delete"
<> short 'd'
<> help "delete an item"
)
)
<*> optional
( strOption
( long "check"
<> short 'c'
<> help "check an item"
)
)
<*> switch (long "tui" <> short 't' <> help "launch a tui app powered by brick")

39
app/FileActions.hs Normal file
View file

@ -0,0 +1,39 @@
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module FileActions where
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import System.Directory
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
TIO.writeFile (folder <> tempFile) result
renameFile (folder <> tempFile) (folder <> file)
delete folder file item = do
content <- TIO.readFile (folder <> file)
let result = T.unlines $ filter (not . item) (T.lines content)
TIO.writeFile (folder <> tempFile) result
renameFile (folder <> tempFile) (folder <> file)
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"

38
app/HtmlPrimitives.hs Normal file
View file

@ -0,0 +1,38 @@
{-# LANGUAGE OverloadedStrings #-}
module HtmlPrimitives where
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 content = "<" <> content <> "/>"
docType = "<!DOCTYPE html>"
h1 = wrapContent "h1"
h2 = wrapContent "h2"
h3 = wrapContent "h3"
link = wrapContent "a"
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)
checkbox id name checked = checkboxPrimitive id name checked <> label id name
-- | Takes a raw line as in untouched from the file
item rawLine = "<form action=\"/post/" <> rawLine <> "\" method=\"POST\"><button type=\"submit\">" <> rawLine <> "</button></form>"
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

9
app/Main.hs Normal file
View file

@ -0,0 +1,9 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Server
main :: IO ()
main = do
runServer

98
app/Server.hs Normal file
View file

@ -0,0 +1,98 @@
{-# LANGUAGE BlockArguments #-}
{-# 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
import Data.ByteString.Lazy.Char8 qualified as L8
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
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 Network.HTTP.Types
import Network.HTTP.Types.URI (urlDecode)
import Network.Wai
import Network.Wai.Handler.Warp (run)
application req respond =
case (requestMethod req, pathInfo req) of
("GET", []) -> do
content <- TIO.readFile "./app/res/b" -- TODO: move that in fileActions
respond $
responseLBS status200 [("Content-Type", "text/html")] $
TLE.encodeUtf8 $
TL.fromStrict $
simpleSite content
("POST", ["check", name]) -> do
FA.check "./app/res/" "b" name
respond $ responseLBS status303 [(hLocation, "/")] "Redirecting..."
-- TODO: refactor this using where better and creating meaningfull local functions
("POST", ["add"]) -> do
putStrLn "adding item"
body <- strictRequestBody req
let args = L8.split '&' body
case args of
[item] -> f item
_ -> error "should have exactly one arg"
where
f item = do
let pair = BL.splitAt 5 item
case pair of
("text=", t) -> do
let text = TE.decodeUtf8 (urlDecode True (BL.toStrict t))
FA.add "./app/res/" "b" text
_ -> error "incorrect args"
respond $ responseLBS status303 [(hLocation, "/")] "Redirecting..."
(method, array) -> do
respond $ responseLBS status303 [(hLocation, "/")] "Redirecting..."
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 = "<!doctype html><html lang=\"" <> lang <> "\"><head><meta charset=\"UTF-8\" /><meta name=\"viewport\" content=\"width=device-width\" /><title>" <> title <> "</title></head>"
tailHtml = "</html>"
h1 = wrapContent "h1"
h2 = wrapContent "h2"
h3 = wrapContent "h3"
link = wrapContent "a"
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)
checkbox id name checked = checkboxPrimitive id name checked <> label id name
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 = T.concat $ map item (T.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>"
rawEditButton = link "/edit"
runServer = do
run 3000 application

15
app/TodoListItem.hs Normal file
View file

@ -0,0 +1,15 @@
module TodoListItem where
data TodoListItem = TodoListItem
{ name :: String
, done :: Bool
}
instance Show TodoListItem where
show (TodoListItem name done) =
s done ++ " " ++ name ++ "\n"
where
s True = "[x]"
s False = "[ ]"
-- TODO: create a class to render items to html to make it easier to create everything for the website using the web primitives

0
app/res/a Normal file
View file

6
app/res/b Normal file
View file

@ -0,0 +1,6 @@
[ ] Wake up
[ ] Eat
[ ] Sleep
[ ] Repeat
[ ] a
[ ] école