From 344d3a1ad41d6b292fe7bf4426c386e8147e3e5f Mon Sep 17 00:00:00 2001 From: Sean Chalmers Date: Fri, 11 Aug 2017 11:11:50 +1000 Subject: [PATCH] Updated level02 structure --- level02/level02.cabal | 39 +++++-- level02/src/FirstApp/Main.hs | 167 ++++++++++++++++++++++++++++ level02/src/{ => FirstApp}/Types.hs | 8 +- level02/src/Main.hs | 166 +-------------------------- level03/src/FirstApp/Types.hs | 6 +- 5 files changed, 206 insertions(+), 180 deletions(-) create mode 100644 level02/src/FirstApp/Main.hs rename level02/src/{ => FirstApp}/Types.hs (93%) diff --git a/level02/level02.cabal b/level02/level02.cabal index d4c9e80..3fbc3c8 100644 --- a/level02/level02.cabal +++ b/level02/level02.cabal @@ -45,16 +45,9 @@ extra-source-files: ChangeLog.md -- Constraint on the version of Cabal needed to build this package. cabal-version: >=1.10 - -executable level02 - -- .hs or .lhs file containing the Main module. - main-is: Main.hs - - -- Modules included in this executable, other than Main. - -- other-modules: - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: +library + exposed-modules: FirstApp.Types + , FirstApp.Main -- Other library packages from which modules are imported. build-depends: base >=4.9 && <4.10 @@ -69,4 +62,30 @@ executable level02 -- Base language which the package is written in. default-language: Haskell2010 + + +executable level02 + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base >=4.9 && <4.10 + , level02 + , wai == 3.2.* + , warp == 3.2.* + , http-types == 0.9.* + , bytestring == 0.10.* + , text == 1.2.* + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell2010 diff --git a/level02/src/FirstApp/Main.hs b/level02/src/FirstApp/Main.hs new file mode 100644 index 0000000..78b73bd --- /dev/null +++ b/level02/src/FirstApp/Main.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE OverloadedStrings #-} +module FirstApp.Main (runApp) where + +import Network.Wai +import Network.Wai.Handler.Warp (run) + +import Network.HTTP.Types (Status, status200, status404, status400, hContentType) + +import qualified Data.ByteString.Lazy as LBS + +import Data.Either (either) + +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) + +import FirstApp.Types + +runApp :: IO () +runApp = run 3000 app + +-- | Just some helper functions to make our lives a little more DRY. +mkResponse + :: Status + -> ContentType + -> LBS.ByteString + -> Response +mkResponse sts ct msg = + responseLBS sts [(hContentType, renderContentType ct)] msg + +resp200 + :: LBS.ByteString + -> Response +resp200 = + mkResponse status200 PlainText + +resp404 + :: LBS.ByteString + -> Response +resp404 = + mkResponse status404 PlainText + +resp400 + :: LBS.ByteString + -> Response +resp400 = + mkResponse status400 PlainText +-- | + +{-| +How can we use the types to make this better? + +We need a way to go from the pathInfo and requestMethod to a Request type +that matches our current specification. +-} +app + :: Application +app rq cb = mkRequest rq + >>= fmap handleRespErr . handleRErr + >>= cb + where + -- Does this seem clunky to you? + handleRespErr = + either mkErrorResponse id + -- Because it is clunky, and we have a better solution, later. + handleRErr = + either ( pure . Left ) handleRequest + +{-| +Lets use our RqTypes to write a function that will take the input from the +Wai library and turn it into something our application cares about. +-} +mkRequest + :: Request + -> IO ( Either Error RqType ) +mkRequest rq = + case ( pathInfo rq, requestMethod rq ) of + -- Commenting on a given topic + ( [t, "add"], "POST" ) -> mkAddRequest t <$> strictRequestBody rq + -- View the comments on a given topic + ( [t, "view"], "GET" ) -> pure ( mkViewRequest t ) + -- List the current topics + ( ["list"], "GET" ) -> pure mkListRequest + -- Finally we don't care about any other requests so throw your hands in the air + _ -> pure mkUnknownRouteErr + +-- These helpers will take the raw request information and turn it into +-- one of our data types. This means we draw a line about where the unruly outside +-- world must end, and where the well-typed world of our application begins. +mkAddRequest + :: Text + -> LBS.ByteString + -> Either Error RqType +mkAddRequest ti c = AddRq + <$> mkTopic ti + <*> (mkCommentText . decodeUtf8 $ LBS.toStrict c) + +-- This has other benefits, we're able isolate our validation requirements into the +-- smallest chunks we can manage. This allows for fantastic reuse and it also means +-- that validation is not spread across the application. It is kept at the borders. +mkViewRequest + :: Text + -> Either Error RqType +mkViewRequest = + fmap ViewRq . mkTopic + +-- Even thought it may seem trivial or even pointless to write functions such as these +-- it allows for much greater consistency across the application. + +-- These are straight forward data constructors, but by doing it this way we don't +-- have any snowflakes littered about the code. It also enhances our ability to +-- spot larger patterns in our application, which are opportunities for abstraction. +mkListRequest + :: Either Error RqType +mkListRequest = + Right ListRq + +{-| +HALP + +Alternative type sig: +Either Error a + +But iirc this isn't as protected against being used in the wrong spot, since the `a` +is polymorphic we could mess up and use this where we're trying to return a Topic. +-} +mkUnknownRouteErr + :: Either Error RqType +mkUnknownRouteErr = + Left UnknownRoute + +mkErrorResponse + :: Error + -> Response +mkErrorResponse UnknownRoute = + resp404 "Unknown Route" +mkErrorResponse EmptyCommentText = + resp400 "Empty Comment" +mkErrorResponse EmptyTopic = + resp400 "Empty Topic" +-- mkErrorResponse _ = +-- error "mkErrorResponse not implemented" + +{-| +We'll stub these for now as the general structure and the process of reaching +this stage is the more important lesson here. + +Notice how we're only accepting our predefined request types that have the required +information already validated and prepared for use in the handling of the request. + +If we find that we need more information to handle a request, or we have a new +type of request that we'd like to handle then we simply update the RqType structure +and the compiler will let us know the affected portions of our application. + +Reduction of concerns such that each section of the application only deals with +a small piece is one of the benefits of developing in this way. +-} +handleRequest + :: RqType + -> IO (Either Error Response) +handleRequest (AddRq _ _) = + pure . Right $ resp200 "Fred wuz ere" +handleRequest (ViewRq _) = + pure . Right $ resp200 "Susan was ere" +handleRequest ListRq = + pure . Right $ resp200 "Fred wuz ere, Susan was ere" +-- handleRequest _ = +-- error "handleRequest not implemented" diff --git a/level02/src/Types.hs b/level02/src/FirstApp/Types.hs similarity index 93% rename from level02/src/Types.hs rename to level02/src/FirstApp/Types.hs index 292ae19..6f0cdf2 100644 --- a/level02/src/Types.hs +++ b/level02/src/FirstApp/Types.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module Types +module FirstApp.Types ( Error (..) , RqType (..) , ContentType (..) @@ -97,6 +97,6 @@ data ContentType renderContentType :: ContentType -> ByteString -renderContentType = error "renderContentType not implemented" --- renderContentType PlainText = "text/plain" --- renderContentType JSON = "text/json" +-- renderContentType = error "renderContentType not implemented" +renderContentType PlainText = "text/plain" +renderContentType JSON = "text/json" diff --git a/level02/src/Main.hs b/level02/src/Main.hs index f0d72ee..88d8f08 100644 --- a/level02/src/Main.hs +++ b/level02/src/Main.hs @@ -1,166 +1,6 @@ -{-# LANGUAGE OverloadedStrings #-} +module Main where -import Network.Wai -import Network.Wai.Handler.Warp (run) - -import Network.HTTP.Types (Status, status200, status404, status400, hContentType) - -import qualified Data.ByteString.Lazy as LBS - -import Data.Either (either) - -import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8) - -import Types +import qualified FirstApp.Main as Main main :: IO () -main = run 3000 app - --- | Just some helper functions to make our lives a little more DRY. -mkResponse - :: Status - -> ContentType - -> LBS.ByteString - -> Response -mkResponse sts ct msg = - responseLBS sts [(hContentType, renderContentType ct)] msg - -resp200 - :: LBS.ByteString - -> Response -resp200 = - mkResponse status200 PlainText - -resp404 - :: LBS.ByteString - -> Response -resp404 = - mkResponse status404 PlainText - -resp400 - :: LBS.ByteString - -> Response -resp400 = - mkResponse status400 PlainText --- | - -{-| -How can we use the types to make this better? - -We need a way to go from the pathInfo and requestMethod to a Request type -that matches our current specification. --} -app - :: Application -app rq cb = mkRequest rq - >>= fmap handleRespErr . handleRErr - >>= cb - where - -- Does this seem clunky to you? - handleRespErr = - either mkErrorResponse id - -- Because it is clunky, and we have a better solution, later. - handleRErr = - either ( pure . Left ) handleRequest - -{-| -Lets use our RqTypes to write a function that will take the input from the -Wai library and turn it into something our application cares about. --} -mkRequest - :: Request - -> IO ( Either Error RqType ) -mkRequest rq = - case ( pathInfo rq, requestMethod rq ) of - -- Commenting on a given topic - ( [t, "add"], "POST" ) -> mkAddRequest t <$> strictRequestBody rq - -- View the comments on a given topic - ( [t, "view"], "GET" ) -> pure ( mkViewRequest t ) - -- List the current topics - ( ["list"], "GET" ) -> pure mkListRequest - -- Finally we don't care about any other requests so throw your hands in the air - _ -> pure mkUnknownRouteErr - --- These helpers will take the raw request information and turn it into --- one of our data types. This means we draw a line about where the unruly outside --- world must end, and where the well-typed world of our application begins. -mkAddRequest - :: Text - -> LBS.ByteString - -> Either Error RqType -mkAddRequest ti c = AddRq - <$> mkTopic ti - <*> (mkCommentText . decodeUtf8 $ LBS.toStrict c) - --- This has other benefits, we're able isolate our validation requirements into the --- smallest chunks we can manage. This allows for fantastic reuse and it also means --- that validation is not spread across the application. It is kept at the borders. -mkViewRequest - :: Text - -> Either Error RqType -mkViewRequest = - fmap ViewRq . mkTopic - --- Even thought it may seem trivial or even pointless to write functions such as these --- it allows for much greater consistency across the application. - --- These are straight forward data constructors, but by doing it this way we don't --- have any snowflakes littered about the code. It also enhances our ability to --- spot larger patterns in our application, which are opportunities for abstraction. -mkListRequest - :: Either Error RqType -mkListRequest = - Right ListRq - -{-| -HALP - -Alternative type sig: -Either Error a - -But iirc this isn't as protected against being used in the wrong spot, since the `a` -is polymorphic we could mess up and use this where we're trying to return a Topic. --} -mkUnknownRouteErr - :: Either Error RqType -mkUnknownRouteErr = - Left UnknownRoute - -mkErrorResponse - :: Error - -> Response -mkErrorResponse UnknownRoute = - resp404 "Unknown Route" -mkErrorResponse EmptyCommentText = - resp400 "Empty Comment" -mkErrorResponse EmptyTopic = - resp400 "Empty Topic" --- mkErrorResponse _ = --- error "mkErrorResponse not implemented" - -{-| -We'll stub these for now as the general structure and the process of reaching -this stage is the more important lesson here. - -Notice how we're only accepting our predefined request types that have the required -information already validated and prepared for use in the handling of the request. - -If we find that we need more information to handle a request, or we have a new -type of request that we'd like to handle then we simply update the RqType structure -and the compiler will let us know the affected portions of our application. - -Reduction of concerns such that each section of the application only deals with -a small piece is one of the benefits of developing in this way. --} -handleRequest - :: RqType - -> IO (Either Error Response) -handleRequest (AddRq _ _) = - pure . Right $ resp200 "Fred wuz ere" -handleRequest (ViewRq _) = - pure . Right $ resp200 "Susan was ere" -handleRequest ListRq = - pure . Right $ resp200 "Fred wuz ere, Susan was ere" --- handleRequest _ = --- error "handleRequest not implemented" +main = Main.runApp diff --git a/level03/src/FirstApp/Types.hs b/level03/src/FirstApp/Types.hs index da31454..6f0cdf2 100644 --- a/level03/src/FirstApp/Types.hs +++ b/level03/src/FirstApp/Types.hs @@ -97,6 +97,6 @@ data ContentType renderContentType :: ContentType -> ByteString -renderContentType = error "renderContentType not implemented" --- renderContentType PlainText = "text/plain" --- renderContentType JSON = "text/json" +-- renderContentType = error "renderContentType not implemented" +renderContentType PlainText = "text/plain" +renderContentType JSON = "text/json"