Commit 0605d390 authored by Oscar Leijendekker's avatar Oscar Leijendekker

Cleanup for ch.6 finished.

parent 6b897d5c
Pipeline #94350579 passed with stage
in 4 minutes and 18 seconds
module HTML where
class HTML a where
toHTML :: a -> String
instance HTML a => HTML [a] where
toHTML listOfElements =
let
elementToListElement :: HTML a => a -> String
elementToListElement element = "<li>" ++ toHTML element ++ "</li>"
in
"<ul>" ++ (concat $ map elementToListElement listOfElements) ++ "</ul>"
toHTMLPage :: HTML a => a -> String
toHTMLPage a =
"<!DOCTYPE html>\
\<html xmlns=\"http://www.w3.org/1999/xhtml\" lang=\"\" xml:lang=\"\">\
\<head>\
\ <meta charset=\"utf-8\" />\
\ <title>TODO list </title>\
\</head>\
\<body>\
\ " ++ toHTML a ++
"</body>"
......@@ -4,21 +4,18 @@ module ServerMain
( startServer
) where
import Network.Wai.Handler.Warp (run)
import HTML (HTML, toHTML, toHTMLPage)
import TaskDB (Task)
import qualified TaskDB
import qualified Network.Wai.Handler.Warp as Warp (run)
import Network.Wai (Request, Response, ResponseReceived, responseLBS)
import Network.HTTP.Types.Status (status200)
import qualified Data.ByteString.Lazy.UTF8 as UTF8 (fromString, toString)
import qualified Data.ByteString.UTF8 as StrictUTF8 (fromString, toString)
import qualified Hasql.Connection
import qualified Hasql.Session
import qualified Hasql.Statement
import qualified Hasql.Encoders
import qualified Hasql.Decoders
import qualified Data.Text
import qualified Data.ByteString.Lazy.UTF8 as UTF8 (fromString)
startServer :: IO ()
startServer = do
run 8080 requestHandler
Warp.run 8080 requestHandler
requestHandler :: Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
requestHandler request respond =
......@@ -27,109 +24,5 @@ requestHandler request respond =
response tasks = responseLBS status200 [] $ htmlPage tasks
in
do
taskList <- fetchFromDB
putStrLn "Received an HTTP request!"
taskList <- TaskDB.fetchFromDB
respond $ response taskList
fetchFromDB :: IO [Task]
fetchFromDB =
let
connectionSettings :: Hasql.Connection.Settings
connectionSettings =
Hasql.Connection.settings
"localhost"
(fromInteger 5432)
"Haskell-student"
"Why-are-you-putting-credentials-in-code?-You-absolute-potato!"
"todolists"
in do
connectionResult <- Hasql.Connection.acquire connectionSettings
case connectionResult of
Left (Just errMsg) -> error $ StrictUTF8.toString errMsg
Left Nothing -> error "Unspecified connection error"
Right connection -> do
queryResult <- Hasql.Session.run selectTasksSession connection
Hasql.Connection.release connection
case queryResult of
Right result -> return result
Left err -> error $ show err
selectTasksSession :: Hasql.Session.Session [Task]
selectTasksSession = Hasql.Session.statement () selectTasksStatement
selectTasksStatement :: Hasql.Statement.Statement () [Task]
selectTasksStatement =
Hasql.Statement.Statement
"SELECT * FROM todolist_ch5"
Hasql.Encoders.unit
tasksDecoder
True
tasksDecoder :: Hasql.Decoders.Result [Task]
tasksDecoder = Hasql.Decoders.rowList taskDecoder
boolToTaskStatus :: Bool -> TaskStatus
boolToTaskStatus True = Done
boolToTaskStatus False = NotDone
taskStatusDecoder :: Hasql.Decoders.Value TaskStatus
taskStatusDecoder = fmap boolToTaskStatus Hasql.Decoders.bool
stringDecoder :: Hasql.Decoders.Value String
stringDecoder = fmap Data.Text.unpack Hasql.Decoders.text
stringDecoder_row :: Hasql.Decoders.Row String
stringDecoder_row = Hasql.Decoders.column stringDecoder
taskStatusDecoder_row :: Hasql.Decoders.Row TaskStatus
taskStatusDecoder_row = Hasql.Decoders.column taskStatusDecoder
taskDecoder :: Hasql.Decoders.Row Task
taskDecoder = Task <$> stringDecoder_row <*> taskStatusDecoder_row
data TaskStatus = Done | NotDone
data Task = Task String TaskStatus
myTask :: Task
myTask = Task "create todo list" NotDone
myTodoList :: [Task]
myTodoList =
[ Task "create todo list" Done
, Task "invent terror drones" NotDone
, Task "achieve world domination" NotDone
]
class HTML a where
toHTML :: a -> String
instance HTML Task where
toHTML task =
case task of
Task description status ->
case status of
NotDone -> "<p>" ++ description ++ "</p>"
Done -> "<p><strike>" ++ description ++ "</strike></p>"
instance HTML a => HTML [a] where
toHTML listOfElements =
let
elementToListElement :: HTML a => a -> String
elementToListElement element = "<li>" ++ toHTML element ++ "</li>"
in
"<ul>" ++ (concat $ map elementToListElement listOfElements) ++ "</ul>"
toHTMLPage :: HTML a => a -> String
toHTMLPage a =
"<!DOCTYPE html>\
\<html xmlns=\"http://www.w3.org/1999/xhtml\" lang=\"\" xml:lang=\"\">\
\<head>\
\ <meta charset=\"utf-8\" />\
\ <title>TODO list </title>\
\</head>\
\<body>\
\ " ++ toHTML a ++
"</body>"
{-# LANGUAGE OverloadedStrings #-}
module TaskDB
( TaskStatus(Done, NotDone)
, Task
, fetchFromDB
) where
import HTML (HTML, toHTML)
import qualified Hasql.Connection
import qualified Hasql.Session
import qualified Hasql.Statement
import qualified Hasql.Encoders
import qualified Hasql.Decoders
import qualified Data.Text
import qualified Data.ByteString.UTF8 as StrictUTF8 (fromString, toString)
data TaskStatus = Done | NotDone
data Task = Task String TaskStatus
instance HTML Task where
toHTML task =
case task of
Task description status ->
case status of
NotDone -> "<p>" ++ description ++ "</p>"
Done -> "<p><strike>" ++ description ++ "</strike></p>"
fetchFromDB :: IO [Task]
fetchFromDB =
let
connectionSettings :: Hasql.Connection.Settings
connectionSettings =
Hasql.Connection.settings
"localhost"
(fromInteger 5432)
"Haskell-student"
"Why-are-you-putting-credentials-in-code?-You-absolute-potato!"
"todolists"
in do
connectionResult <- Hasql.Connection.acquire connectionSettings
case connectionResult of
Left (Just errMsg) -> error $ StrictUTF8.toString errMsg
Left Nothing -> error "Unspecified connection error"
Right connection -> do
queryResult <- Hasql.Session.run selectTasksSession connection
Hasql.Connection.release connection
case queryResult of
Right result -> return result
Left err -> error $ show err
selectTasksSession :: Hasql.Session.Session [Task]
selectTasksSession = Hasql.Session.statement () selectTasksStatement
selectTasksStatement :: Hasql.Statement.Statement () [Task]
selectTasksStatement =
Hasql.Statement.Statement
"SELECT * FROM todolist_ch5"
Hasql.Encoders.unit
tasksDecoder
True
tasksDecoder :: Hasql.Decoders.Result [Task]
tasksDecoder = Hasql.Decoders.rowList taskDecoder
boolToTaskStatus :: Bool -> TaskStatus
boolToTaskStatus True = Done
boolToTaskStatus False = NotDone
taskStatusDecoder :: Hasql.Decoders.Value TaskStatus
taskStatusDecoder = fmap boolToTaskStatus Hasql.Decoders.bool
stringDecoder :: Hasql.Decoders.Value String
stringDecoder = fmap Data.Text.unpack Hasql.Decoders.text
stringDecoder_row :: Hasql.Decoders.Row String
stringDecoder_row = Hasql.Decoders.column stringDecoder
taskStatusDecoder_row :: Hasql.Decoders.Row TaskStatus
taskStatusDecoder_row = Hasql.Decoders.column taskStatusDecoder
taskDecoder :: Hasql.Decoders.Row Task
taskDecoder = Task <$> stringDecoder_row <*> taskStatusDecoder_row
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment