diff --git a/src/Level04/Core.hs b/src/Level04/Core.hs index 158c70e6..5e61601f 100644 --- a/src/Level04/Core.hs +++ b/src/Level04/Core.hs @@ -1,55 +1,69 @@ {-# LANGUAGE OverloadedStrings #-} -module Level04.Core - ( runApp - , prepareAppReqs - , app - ) where - -import Control.Applicative (liftA2) -import Control.Monad (join) - -import Network.Wai (Application, Request, - Response, pathInfo, - requestMethod, responseLBS, - strictRequestBody) -import Network.Wai.Handler.Warp (run) - -import Network.HTTP.Types (Status, hContentType, - status200, status400, - status404, status500) - -import qualified Data.ByteString.Lazy.Char8 as LBS -import Data.Either (Either (Left, Right), - either) - -import Data.Semigroup ((<>)) -import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8) -import Data.Text.Lazy.Encoding (encodeUtf8) - -import Database.SQLite.SimpleErrors.Types (SQLiteResponse) - -import Waargonaut.Encode (Encoder') -import qualified Waargonaut.Encode as E - -import Level04.Conf (Conf, firstAppConfig) -import qualified Level04.DB as DB -import Level04.Types (ContentType (JSON, PlainText), - Error (EmptyCommentText, EmptyTopic, UnknownRoute), - RqType (AddRq, ListRq, ViewRq), - mkCommentText, mkTopic, - renderContentType) +module Level04.Core + ( runApp, + prepareAppReqs, + app, + ) +where + +import Control.Applicative (liftA2) +import Control.Monad (join) +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Either + ( Either (Left, Right), + either, + ) +import Data.Semigroup ((<>)) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import Data.Text.Lazy.Encoding (encodeUtf8) +import Database.SQLite.SimpleErrors.Types (SQLiteResponse) +import Level04.Conf (Conf (..), firstAppConfig) +import Level04.DB (initDB) +import qualified Level04.DB as DB +import Level04.Types + ( ContentType (JSON, PlainText), + Error (..), + RqType (AddRq, ListRq, ViewRq), + mkCommentText, + mkTopic, + renderContentType, + ) +import Network.HTTP.Types + ( Status, + hContentType, + status200, + status400, + status404, + status500, + ) +import Network.Wai + ( Application, + Request, + Response, + pathInfo, + requestMethod, + responseLBS, + strictRequestBody, + ) +import Network.Wai.Handler.Warp (run) +import Waargonaut.Encode (Encoder') +import qualified Waargonaut.Encode as E -- Our start-up is becoming more complicated and could fail in new and -- interesting ways. But we also want to be able to capture these errors in a -- single type so that we can deal with the entire start-up process as a whole. data StartUpError = DBInitErr SQLiteResponse - deriving Show + deriving (Show) runApp :: IO () -runApp = error "runApp needs re-implementing" +runApp = do + prepResult <- prepareAppReqs + case prepResult of + Left err -> putStr (show err) + Right db -> run 3000 (app db) -- We need to complete the following steps to prepare our app requirements: -- @@ -58,61 +72,65 @@ runApp = error "runApp needs re-implementing" -- -- Our application configuration is defined in Conf.hs -- -prepareAppReqs - :: IO ( Either StartUpError DB.FirstAppDB ) -prepareAppReqs = - error "prepareAppReqs not implemented" +prepareAppReqs :: + IO (Either StartUpError DB.FirstAppDB) +prepareAppReqs = do + initResult <- initDB $ dbFilePath firstAppConfig + pure $ case initResult of + Left e -> Left $ DBInitErr e + Right db -> Right db -- | Some helper functions to make our lives a little more DRY. -mkResponse - :: Status - -> ContentType - -> LBS.ByteString - -> Response +mkResponse :: + Status -> + ContentType -> + LBS.ByteString -> + Response mkResponse sts ct = responseLBS sts [(hContentType, renderContentType ct)] -resp200 - :: ContentType - -> LBS.ByteString - -> Response +resp200 :: + ContentType -> + LBS.ByteString -> + Response resp200 = mkResponse status200 -resp404 - :: ContentType - -> LBS.ByteString - -> Response +resp404 :: + ContentType -> + LBS.ByteString -> + Response resp404 = mkResponse status404 -resp400 - :: ContentType - -> LBS.ByteString - -> Response +resp400 :: + ContentType -> + LBS.ByteString -> + Response resp400 = mkResponse status400 -- Some new helpers for different statuses and content types -resp500 - :: ContentType - -> LBS.ByteString - -> Response +resp500 :: + ContentType -> + LBS.ByteString -> + Response resp500 = mkResponse status500 -resp200Json - :: Encoder' a - -> a - -> Response +resp200Json :: + Encoder' a -> + a -> + Response resp200Json e = - mkResponse status200 JSON . encodeUtf8 . - E.simplePureEncodeTextNoSpaces e + mkResponse status200 JSON . encodeUtf8 + . E.simplePureEncodeTextNoSpaces e -- | -app - :: DB.FirstAppDB -- ^ Add the Database record to our app so we can use it - -> Application +app :: + -- | Add the Database record to our app so we can use it + DB.FirstAppDB -> + Application app db rq cb = do rq' <- mkRequest rq resp <- handleRespErr <$> handleRErr rq' @@ -124,7 +142,7 @@ app db rq cb = do -- We want to pass the Database through to the handleRequest so it's -- available to all of our handlers. handleRErr :: Either Error RqType -> IO (Either Error Response) - handleRErr = either ( pure . Left ) ( handleRequest db ) + handleRErr = either (pure . Left) (handleRequest db) -- | Handle each of the different types of request. See how the types have helped narrow our focus -- to only those types of request that we care about. Along with ensuring that once the data has @@ -134,56 +152,59 @@ app db rq cb = do -- -- For both the 'ViewRq' and 'ListRq' functions, we'll need to pass the correct 'Encoder' to the -- 'resp200Json' function. -handleRequest - :: DB.FirstAppDB - -> RqType - -> IO (Either Error Response) +handleRequest :: + DB.FirstAppDB -> + RqType -> + IO (Either Error Response) handleRequest _db (AddRq _ _) = (resp200 PlainText "Success" <$) <$> error "AddRq handler not implemented" -handleRequest _db (ViewRq _) = +handleRequest _db (ViewRq _) = error "ViewRq handler not implemented" -handleRequest _db ListRq = +handleRequest _db ListRq = error "ListRq handler not implemented" -mkRequest - :: Request - -> IO ( Either Error RqType ) +mkRequest :: + Request -> + IO (Either Error RqType) mkRequest rq = - case ( pathInfo rq, requestMethod rq ) of + case (pathInfo rq, requestMethod rq) of -- Commenting on a given topic - ( [t, "add"], "POST" ) -> mkAddRequest t <$> strictRequestBody rq + ([t, "add"], "POST") -> mkAddRequest t <$> strictRequestBody rq -- View the comments on a given topic - ( [t, "view"], "GET" ) -> pure ( mkViewRequest t ) + ([t, "view"], "GET") -> pure (mkViewRequest t) -- List the current topics - ( ["list"], "GET" ) -> pure mkListRequest + (["list"], "GET") -> pure mkListRequest -- Finally we don't care about any other requests so throw your hands in the air - _ -> pure ( Left UnknownRoute ) - -mkAddRequest - :: Text - -> LBS.ByteString - -> Either Error RqType -mkAddRequest ti c = AddRq - <$> mkTopic ti - <*> (mkCommentText . decodeUtf8 . LBS.toStrict) c - -mkViewRequest - :: Text - -> Either Error RqType + _ -> pure (Left UnknownRoute) + +mkAddRequest :: + Text -> + LBS.ByteString -> + Either Error RqType +mkAddRequest ti c = + AddRq + <$> mkTopic ti + <*> (mkCommentText . decodeUtf8 . LBS.toStrict) c + +mkViewRequest :: + Text -> + Either Error RqType mkViewRequest = fmap ViewRq . mkTopic -mkListRequest - :: Either Error RqType +mkListRequest :: + Either Error RqType mkListRequest = Right ListRq -mkErrorResponse - :: Error - -> Response +mkErrorResponse :: + Error -> + Response mkErrorResponse UnknownRoute = resp404 PlainText "Unknown Route" mkErrorResponse EmptyCommentText = resp400 PlainText "Empty Comment" mkErrorResponse EmptyTopic = resp400 PlainText "Empty Topic" +mkErrorResponse DBError = + resp400 PlainText "Database Error" diff --git a/src/Level04/DB.hs b/src/Level04/DB.hs index 240e4442..960c81b9 100644 --- a/src/Level04/DB.hs +++ b/src/Level04/DB.hs @@ -1,28 +1,41 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} -module Level04.DB - ( FirstAppDB (FirstAppDB) - , initDB - , closeDB - , addCommentToTopic - , getComments - , getTopics - , deleteTopic - ) where - -import Data.Text (Text) -import qualified Data.Text as Text - -import Data.Time (getCurrentTime) -import Database.SQLite.Simple (Connection, Query (Query)) -import qualified Database.SQLite.Simple as Sql - -import qualified Database.SQLite.SimpleErrors as Sql -import Database.SQLite.SimpleErrors.Types (SQLiteResponse) +module Level04.DB + ( FirstAppDB (FirstAppDB), + initDB, + closeDB, + addCommentToTopic, + getComments, + getTopics, + deleteTopic, + ) +where -import Level04.Types (Comment, CommentText, - Error, Topic) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time (UTCTime, getCurrentTime) +import Database.SQLite.Simple + ( Connection, + Query (Query), + close, + executeNamed, + execute_, + open, + queryNamed, + ) +import qualified Database.SQLite.Simple as Sql +import qualified Database.SQLite.SimpleErrors as Sql +import Database.SQLite.SimpleErrors.Types (SQLiteResponse) +import Level04.DB.Types (DBComment) +import Level04.Types + ( Comment (..), + CommentText (..), + Error (..), + Topic (..), + fromDBComment, + getTopic, + ) -- ------------------------------------------------------------------------------| -- You'll need the documentation for sqlite-simple & sqlite-simple-errors handy! | @@ -40,24 +53,25 @@ data FirstAppDB = FirstAppDB } -- Quick helper to pull the connection and close it down. -closeDB - :: FirstAppDB - -> IO () -closeDB = - error "closeDB not implemented" +closeDB :: + FirstAppDB -> + IO () +closeDB db = close (dbConn db) -- Given a `FilePath` to our SQLite DB file, initialise the database and ensure -- our Table is there by running a query to create it, if it doesn't exist -- already. -initDB - :: FilePath - -> IO ( Either SQLiteResponse FirstAppDB ) -initDB fp = - error "initDB not implemented (use Sql.runDBAction to catch exceptions)" +initDB :: + FilePath -> + IO (Either SQLiteResponse FirstAppDB) +initDB fp = do + -- :: Connection + conn <- open fp + -- :: Either SqliteResponse () + exec <- Sql.runDBAction $ execute_ conn createTableQ + -- :: IO (Either SqliteResponse FirstAppDB) + pure $ FirstAppDB conn <$ exec where - -- Query has an `IsString` instance so string literals like this can be - -- converted into a `Query` type when the `OverloadedStrings` language - -- extension is enabled. createTableQ = "CREATE TABLE IF NOT EXISTS comments (id INTEGER PRIMARY KEY, topic TEXT, comment TEXT, time TEXT)" -- Note that we don't store the `Comment` in the DB, it is the type we build @@ -70,46 +84,60 @@ initDB fp = -- -- HINT: You can use '?' or named place-holders as query parameters. Have a look -- at the section on parameter substitution in sqlite-simple's documentation. -getComments - :: FirstAppDB - -> Topic - -> IO (Either Error [Comment]) -getComments = - let - sql = "SELECT id,topic,comment,time FROM comments WHERE topic = ?" - -- There are several possible implementations of this function. Particularly - -- there may be a trade-off between deciding to throw an Error if a DBComment - -- cannot be converted to a Comment, or simply ignoring any DBComment that is - -- not valid. - in - error "getComments not implemented (use Sql.runDBAction to catch exceptions)" -addCommentToTopic - :: FirstAppDB - -> Topic - -> CommentText - -> IO (Either Error ()) -addCommentToTopic = - let - sql = "INSERT INTO comments (topic,comment,time) VALUES (?,?,?)" - in - error "addCommentToTopic not implemented (use Sql.runDBAction to catch exceptions)" +getComments :: + FirstAppDB -> + Topic -> + IO (Either Error [Comment]) +getComments (FirstAppDB conn) (Topic t) = + let sql = "SELECT id,topic,comment,time FROM comments WHERE topic = @topic" + queryToRun = queryNamed conn sql ["@topic" Sql.:= t] :: IO [DBComment] + replaceBits res = case res of + Left _ -> Left DBError + -- If any DBComment turns into an error, throw an overall error + Right r -> Right (fromDBComment <$> r) >>= sequence + in replaceBits <$> Sql.runDBAction queryToRun + +addCommentToTopic :: + FirstAppDB -> + Topic -> + CommentText -> + IO (Either Error ()) +addCommentToTopic (FirstAppDB conn) (Topic t) (CommentText ct) = + let sql = "INSERT INTO comments (topic,comment,time) VALUES (@topic,@comment,@time)" + --time = getCurrentTime + queryToRun time = + executeNamed + conn + sql + [ "@topic" Sql.:= t, + "@comment" Sql.:= ct, + "@time" Sql.:= time + ] + replaceBits res = case res of + Left _ -> Left DBError + Right r -> Right r + in replaceBits <$> Sql.runDBAction (getCurrentTime >>= queryToRun) -getTopics - :: FirstAppDB - -> IO (Either Error [Topic]) -getTopics = - let - sql = "SELECT DISTINCT topic FROM comments" - in - error "getTopics not implemented (use Sql.runDBAction to catch exceptions)" +getTopics :: + FirstAppDB -> + IO (Either Error [Topic]) +getTopics (FirstAppDB conn) = + let sql = "SELECT DISTINCT topic FROM comments" + queryToRun = queryNamed conn sql [] :: IO [Topic] + replaceBits res = case res of + Left _ -> Left DBError + Right r -> Right r + in replaceBits <$> Sql.runDBAction queryToRun -deleteTopic - :: FirstAppDB - -> Topic - -> IO (Either Error ()) -deleteTopic = - let - sql = "DELETE FROM comments WHERE topic = ?" - in - error "deleteTopic not implemented (use Sql.runDBAction to catch exceptions)" +deleteTopic :: + FirstAppDB -> + Topic -> + IO (Either Error ()) +deleteTopic (FirstAppDB conn) (Topic t) = + let sql = "DELETE FROM comments WHERE topic = @topic" + queryToRun = executeNamed conn sql ["@topic" Sql.:= t] + replaceBits res = case res of + Left _ -> Left DBError + Right r -> Right r + in replaceBits <$> Sql.runDBAction queryToRun diff --git a/src/Level04/DB/Types.hs b/src/Level04/DB/Types.hs index ee1ee69e..d9f30f0a 100644 --- a/src/Level04/DB/Types.hs +++ b/src/Level04/DB/Types.hs @@ -1,10 +1,10 @@ {-# OPTIONS_GHC -fno-warn-missing-methods #-} -module Level04.DB.Types where -import Data.Text (Text) -import Data.Time (UTCTime) +module Level04.DB.Types (DBComment (..)) where -import Database.SQLite.Simple.FromRow (FromRow (fromRow), field) +import Data.Text (Text) +import Data.Time (UTCTime) +import Database.SQLite.Simple.FromRow (FromRow (fromRow), field) -- To try to avoid leaking various types and expected functionality around the -- application, we create a stand alone type that will represent the data we @@ -14,15 +14,28 @@ import Database.SQLite.Simple.FromRow (FromRow (fromRow), field) -- Complete in the DBComment type below so it is a record type that matches the -- Comment type, but without the newtype wrappers for each value. To get started, -- just copy the new definition for the `Comment` type from Level04.Types. +--data Comment = Comment +-- { commentId :: CommentId +-- , commentTopic :: Topic +-- , commentBody :: CommentText +-- , commentTime :: UTCTime +-- } +-- deriving Show data DBComment = DBComment - -- NB: Haskell does not allow duplicate field names for records so the field - -- names for this type will have to be slightly different + { dbCommentId :: Int, + dbCommentTopic :: Text, + dbCommentBody :: Text, + dbCommentTime :: UTCTime + } + +-- NB: Haskell does not allow duplicate field names for records so the field +-- names for this type will have to be slightly different -- This Typeclass comes from the `sqlite-simple` package and describes how to -- decode a single row from the database into a single representation of our -- type. This technique of translating a result row to a type will differ -- between different packages/databases. instance FromRow DBComment where - fromRow = error "FromRow DBComment instance not implemented" + fromRow = DBComment <$> field <*> field <*> field <*> field -- Now move to ``src/Level04/Types.hs`` diff --git a/src/Level04/Types.hs b/src/Level04/Types.hs index 68de2a37..0d19efe9 100644 --- a/src/Level04/Types.hs +++ b/src/Level04/Types.hs @@ -5,8 +5,8 @@ module Level04.Types ( Error (..) , RqType (..) , ContentType (..) - , Topic - , CommentText + , Topic (..) + , CommentText (..) , Comment (..) , mkTopic , getTopic @@ -26,26 +26,26 @@ import Data.Maybe (fromMaybe) import Data.Functor.Contravariant ((>$<)) -import Data.Time (UTCTime) +import Data.Time (UTCTime (..)) import qualified Data.Time.Format as TF import Waargonaut.Encode (Encoder) import qualified Waargonaut.Encode as E -import Level04.DB.Types (DBComment) +import Level04.DB.Types (DBComment (..)) -- | Notice how we've moved these types into their own modules. It's cheap and -- easy to add modules to carve out components in a Haskell application. So -- whenever you think that a module is too big, covers more than one piece of -- distinct functionality, or you want to carve out a particular piece of code, -- just spin up another module. -import Level04.Types.CommentText (CommentText, getCommentText, - mkCommentText) -import Level04.Types.Topic (Topic, getTopic, mkTopic) +import Level04.Types.CommentText (CommentText (..), getCommentText, + mkCommentText, commentToText) +import Level04.Types.Topic (Topic (..), getTopic, mkTopic) -import Level04.Types.Error (Error (EmptyCommentText, EmptyTopic, UnknownRoute)) +import Level04.Types.Error (Error (..)) -newtype CommentId = CommentId Int +newtype CommentId = CommentId {intFromId :: Int} deriving (Eq, Show) -- | This is the `Comment` record that we will be sending to users, it's a @@ -66,8 +66,11 @@ data Comment = Comment -- 'https://hackage.haskell.org/package/waargonaut/docs/Waargonaut-Encode.html' -- encodeComment :: Applicative f => Encoder f Comment -encodeComment = - error "Comment JSON encoder not implemented" +encodeComment = E.mapLikeObj $ \c -> + E.atKey' "id" E.int (intFromId $ commentId c) . + E.atKey' "topic" E.text (getTopic $ commentTopic c) . + E.atKey' "body" E.text (commentToText $ commentBody c) . + E.atKey' "time" encodeISO8601DateTime (commentTime c) -- Tip: Use the 'encodeISO8601DateTime' to handle the UTCTime for us. -- | For safety we take our stored `DBComment` and try to construct a `Comment` @@ -77,8 +80,12 @@ encodeComment = fromDBComment :: DBComment -> Either Error Comment -fromDBComment = - error "fromDBComment not yet implemented" +fromDBComment dc = + pure $ Comment + (CommentId $ dbCommentId dc) + (Topic $ dbCommentTopic dc) + (CommentText $ dbCommentBody dc) + (dbCommentTime dc) data RqType = AddRq Topic CommentText diff --git a/src/Level04/Types/CommentText.hs b/src/Level04/Types/CommentText.hs index 865ebba8..fb22dace 100644 --- a/src/Level04/Types/CommentText.hs +++ b/src/Level04/Types/CommentText.hs @@ -1,30 +1,32 @@ module Level04.Types.CommentText - ( CommentText - , mkCommentText - , getCommentText - ) where + ( CommentText (..), + mkCommentText, + getCommentText, + commentToText, + ) +where -import Waargonaut.Encode (Encoder) -import qualified Waargonaut.Encode as E - -import Level04.Types.Error (Error (EmptyCommentText), - nonEmptyText) - -import Data.Functor.Contravariant (contramap) -import Data.Text (Text) +import Data.Functor.Contravariant (contramap) +import Data.Text (Text) +import Level04.Types.Error + ( Error (EmptyCommentText), + nonEmptyText, + ) +import Waargonaut.Encode (Encoder) +import qualified Waargonaut.Encode as E newtype CommentText = CommentText Text - deriving Show + deriving (Show) -mkCommentText - :: Text - -> Either Error CommentText +mkCommentText :: + Text -> + Either Error CommentText mkCommentText = nonEmptyText CommentText EmptyCommentText -getCommentText - :: CommentText - -> Text +getCommentText :: + CommentText -> + Text getCommentText (CommentText t) = t @@ -51,7 +53,10 @@ getCommentText (CommentText t) = -- typeclass has a function that comes in very handy when writing these -- functions. There is a quick introduction to `Contravariant` in the `README` -- for this level. --- +commentToText :: CommentText -> Text +commentToText (CommentText ct) = ct + encodeCommentText :: Applicative f => Encoder f CommentText -encodeCommentText = -- Try using 'contramap' and 'E.text'. - error "CommentText JSON encoder not implemented" +encodeCommentText = + -- Try using 'contramap' and 'E.text'. + contramap commentToText E.text diff --git a/src/Level04/Types/Error.hs b/src/Level04/Types/Error.hs index 58ef4472..96b6f1e1 100644 --- a/src/Level04/Types/Error.hs +++ b/src/Level04/Types/Error.hs @@ -1,8 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} + module Level04.Types.Error - ( Error(..) - , nonEmptyText - ) where + ( Error (..), + nonEmptyText, + ) +where import Data.Text (Text) @@ -10,13 +12,13 @@ data Error = UnknownRoute | EmptyCommentText | EmptyTopic - -- Add another constructor for our DB error types. + | DBError deriving (Eq, Show) -nonEmptyText - :: (Text -> a) - -> Error - -> Text - -> Either Error a +nonEmptyText :: + (Text -> a) -> + Error -> + Text -> + Either Error a nonEmptyText _ e "" = Left e nonEmptyText c _ tx = Right (c tx) diff --git a/src/Level04/Types/Topic.hs b/src/Level04/Types/Topic.hs index d81c5c1c..c1abdac0 100644 --- a/src/Level04/Types/Topic.hs +++ b/src/Level04/Types/Topic.hs @@ -1,30 +1,30 @@ module Level04.Types.Topic - ( Topic - , mkTopic - , getTopic - , encodeTopic - ) where + ( Topic (..), + mkTopic, + getTopic, + encodeTopic, + ) +where -import Waargonaut.Encode (Encoder) -import qualified Waargonaut.Encode as E - -import Data.Functor.Contravariant (contramap) -import Data.Text (Text) - -import Level04.Types.Error (Error (EmptyTopic), nonEmptyText) +import Data.Functor.Contravariant (contramap) +import Data.Text (Text) +import Database.SQLite.Simple.FromRow (FromRow (fromRow), field) +import Level04.Types.Error (Error (EmptyTopic), nonEmptyText) +import Waargonaut.Encode (Encoder) +import qualified Waargonaut.Encode as E newtype Topic = Topic Text - deriving Show + deriving (Show) -mkTopic - :: Text - -> Either Error Topic +mkTopic :: + Text -> + Either Error Topic mkTopic = nonEmptyText Topic EmptyTopic -getTopic - :: Topic - -> Text +getTopic :: + Topic -> + Text getTopic (Topic t) = t @@ -58,7 +58,10 @@ getTopic (Topic t) = -- typeclass has a function that comes in very handy when writing these -- functions. There is a quick introduction to `Contravariant` in the `README` -- for this level. --- encodeTopic :: Applicative f => Encoder f Topic -encodeTopic = -- Try using 'contramap' and 'E.text' - error "topic JSON encoder not implemented" +encodeTopic = + -- Try using 'contramap' and 'E.text' + contramap getTopic E.text + +instance FromRow Topic where + fromRow = Topic <$> field