Progress on Level04

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"