Updated Response Builder Functions

Changed up the Response builder functions to be consistent with
the need to pass in the ContentType when constructing the response.

level03/src/FirstApp/Main.hs

@@ -36,22 +36,25 @@ mkResponse sts ct msg =
   responseLBS sts [(hContentType, renderContentType ct)] msg
 
 resp200
-  :: LBS.ByteString
+  :: ContentType
+  -> LBS.ByteString
   -> Response
 resp200 =
-  mkResponse status200 PlainText
+  mkResponse status200
 
 resp404
-  :: LBS.ByteString
+  :: ContentType
+  -> LBS.ByteString
   -> Response
 resp404 =
-  mkResponse status404 PlainText
+  mkResponse status404
 
 resp400
-  :: LBS.ByteString
+  :: ContentType
+  -> LBS.ByteString
   -> Response
 resp400 =
-  mkResponse status400 PlainText
+  mkResponse status400
 -- |
 
 -- Now that we have our configuration, pass it where it needs to go.
@@ -76,11 +79,11 @@ handleRequest
   -> RqType
   -> Either Error Response
 handleRequest _cfg (AddRq _ _) =
-  Right . resp200 $ "App says: " <> undefined
+  Right . resp200 PlainText $ "App says: " <> undefined
 handleRequest _ (ViewRq _) =
-  Right $ resp200 "Susan was here"
+  Right $ resp200 PlainText "Susan was here"
 handleRequest _ ListRq =
-  Right $ resp200 "[ \"Fred was here\", \"Susan was here\" ]"
+  Right $ resp200 PlainText "[ \"Fred was here\", \"Susan was here\" ]"
 
 mkRequest
   :: Request
@@ -88,13 +91,17 @@ mkRequest
 mkRequest rq =
   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 mkUnknownRouteErr
+    _                      ->
+      pure mkUnknownRouteErr
 
 mkAddRequest
   :: Text
@@ -124,9 +131,9 @@ mkErrorResponse
   :: Error
   -> Response
 mkErrorResponse UnknownRoute =
-  resp404 "Unknown Route"
+  resp404 PlainText "Unknown Route"
 mkErrorResponse EmptyCommentText =
-  resp400 "Empty Comment"
+  resp400 PlainText "Empty Comment"
 mkErrorResponse EmptyTopic =
-  resp400 "Empty Topic"
+  resp400 PlainText "Empty Topic"
 

level04/src/FirstApp/Main.hs

@@ -34,22 +34,25 @@ mkResponse sts ct msg =
   responseLBS sts [(hContentType, renderContentType ct)] msg
 
 resp200
-  :: LBS.ByteString
+  :: ContentType
+  -> LBS.ByteString
   -> Response
 resp200 =
-  mkResponse status200 PlainText
+  mkResponse status200
 
 resp404
-  :: LBS.ByteString
+  :: ContentType
+  -> LBS.ByteString
   -> Response
 resp404 =
-  mkResponse status404 PlainText
+  mkResponse status404
 
 resp400
-  :: LBS.ByteString
+  :: ContentType
+  -> LBS.ByteString
   -> Response
 resp400 =
-  mkResponse status400 PlainText
+  mkResponse status400
 -- |
 
 app
@@ -71,11 +74,11 @@ handleRequest
   -> RqType
   -> Either Error Response
 handleRequest cfg (AddRq _ _) =
-  Right $ resp200 (Conf.mkMessage cfg)
+  Right $ resp200 PlainText (Conf.mkMessage cfg)
 handleRequest _ (ViewRq _) =
-  Right $ resp200 "Susan was here"
+  Right $ resp200 PlainText "Susan was here"
 handleRequest _ ListRq =
-  Right $ resp200 "[ \"Fred was here\", \"Susan was here\" ]"
+  Right $ resp200 PlainText "[ \"Fred was here\", \"Susan was here\" ]"
 
 mkRequest
   :: Request
@@ -119,9 +122,9 @@ mkErrorResponse
   :: Error
   -> Response
 mkErrorResponse UnknownRoute =
-  resp404 "Unknown Route"
+  resp404 PlainText "Unknown Route"
 mkErrorResponse EmptyCommentText =
-  resp400 "Empty Comment"
+  resp400 PlainText "Empty Comment"
 mkErrorResponse EmptyTopic =
-  resp400 "Empty Topic"
+  resp400 PlainText "Empty Topic"
 

level06/src/FirstApp/Main.hs

@@ -79,12 +79,14 @@ prepareAppReqs = do
     toStartUpErr =
       fmap . first
 
-    initConf = toStartUpErr ConfErr
+    initConf =
       -- Prepare the configgening
+      toStartUpErr ConfErr
       $ Conf.parseOptions "appconfig.json"
 
-    initDB cfg = toStartUpErr DbInitErr
+    initDB cfg =
       -- Power up the tubes
+      toStartUpErr DbInitErr
       $ DB.initDb (Conf.dbFilePath cfg) (Conf.tableName cfg)
 
 app
@@ -130,7 +132,7 @@ handleRequest rqType = do
   liftIO $ case rqType of
     -- Exercise: Could this be generalised to clean up the repetition ?
     AddRq t c ->
-      (pure (Res.resp200 PlainText "Success")) <$ DB.addCommentToTopic db t c
+      pure (Res.resp200 PlainText "Success") <$ DB.addCommentToTopic db t c
     ViewRq t  ->
       fmap Res.resp200Json <$> DB.getComments db t
     ListRq    ->
@@ -191,6 +193,6 @@ mkErrorResponse ( DBError e )    = do
   -- As with our request for the FirstAppDB, we use the asks function from
   -- Control.Monad.Reader and pass the field accessor from the Env record.
   rick <- asks envLoggingFn
-  (rick . Text.pack . show) e
+  _ <- (rick . Text.pack . show) e
   -- Be a sensible developer and don't leak your DB errors over the interwebs.
   pure (Res.resp500 PlainText "OH NOES")