{-# 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 = " lang <> "\">" <> title <> ""
tailHtml = ""
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 = ""
newItemForm = ""
rawEditButton = link "/edit"
runServer = do
run 3000 application