88 lines
4.4 KiB
Haskell
88 lines
4.4 KiB
Haskell
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE ImportQualifiedPost #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
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 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
|
|
content <- FA.readF "./app/res/" "b"
|
|
respond $
|
|
responseLBS status200 [("Content-Type", "text/html")] $
|
|
convert $
|
|
mainPage (show content) -- TODO: check if necessary to use text
|
|
("GET", ["edit"]) -> do
|
|
content <- FA.readF "./app/res/" "b"
|
|
respond $
|
|
responseLBS status200 [("Content-Type", "text/html")] $
|
|
convert $
|
|
editPage (show content)
|
|
("POST", ["edit"]) -> do
|
|
-- TODO: refactor this shit
|
|
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))
|
|
print 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" (read $ T.unpack 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))
|
|
let item = read (T.unpack text) :: TodoListItem
|
|
FA.appendF "./app/res/" "b" [item]
|
|
_ -> 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)
|
|
|
|
runServer = do
|
|
run 3000 application
|
|
|
|
convert = BL.fromStrict . TE.encodeUtf8 . T.pack
|