134 lines
6.6 KiB
Haskell
134 lines
6.6 KiB
Haskell
{-# 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
|
|
("GET", ["edit"]) -> do
|
|
content <- TIO.readFile "./app/res/b" -- TODO: move that in fileActions
|
|
respond $
|
|
responseLBS status200 [("Content-Type", "text/html")] $
|
|
TLE.encodeUtf8 $
|
|
TL.fromStrict $
|
|
editPage 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
|
|
case args of
|
|
[newList] -> f newList
|
|
_ -> error "should have exactly one arg"
|
|
where
|
|
f newList = do
|
|
let pair = BL.splitAt 5 newList
|
|
case pair of
|
|
("list=", t) -> do
|
|
let text = TE.decodeUtf8 (urlDecode True (BL.toStrict t))
|
|
FA.write "./app/res/" "b" text
|
|
_ -> error "incorrect args"
|
|
respond $ responseLBS status303 [(hLocation, "/")] "Redirecting..."
|
|
("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><body>"
|
|
tailHtml = "</body></html>"
|
|
br = "<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 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>"
|
|
|
|
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
|