mirror of
https://github.com/qfpl/applied-fp-course.git
synced 2024-11-23 03:44:45 +03:00
More wording updates
Removed more commented out code, removed some of the hand holding I had and added some more indication of when you should probably just reach for the docs
This commit is contained in:
Sean Chalmers
parent
5ba01551ad
commit
4aa22d0e0b
@ -30,19 +30,13 @@ import Options.Applicative (Parser, ParserInfo, eitherReader,
|
||||
|
||||
import Text.Read (readEither)
|
||||
|
||||
{-|
|
||||
Similar to when we were considering what might go wrong with the RqTypes, lets
|
||||
think about might go wrong when trying to gather our configuration information.
|
||||
-}
|
||||
-- Similar to when we were considering what might go wrong with the RqTypes, lets
|
||||
-- think about might go wrong when trying to gather our configuration information.
|
||||
data ConfigError
|
||||
= MissingPort
|
||||
| MissingHelloMsg
|
||||
deriving Show
|
||||
|
||||
{-|
|
||||
As before, a bare Int or ByteString doesn't tell us anything about our intent,
|
||||
so lets wrap it up in a newtype.
|
||||
-}
|
||||
newtype Port = Port
|
||||
{ getPort :: Int }
|
||||
deriving Show
|
||||
@ -51,8 +45,6 @@ newtype HelloMsg = HelloMsg
|
||||
{ getHelloMsg :: ByteString }
|
||||
deriving Show
|
||||
|
||||
-- This is a helper function to take a string and turn it into our HelloMsg
|
||||
-- type.
|
||||
helloFromStr
|
||||
:: String
|
||||
-> HelloMsg
|
||||
@ -66,57 +58,19 @@ mkMessage =
|
||||
mappend "App says: "
|
||||
. getHelloMsg
|
||||
. helloMsg
|
||||
{-|
|
||||
This will be our configuration value, eventually it may contain more things
|
||||
but this will do for now. We will have a customisable port number, and a
|
||||
changeable message for our users.
|
||||
-}
|
||||
|
||||
data Conf = Conf
|
||||
{ port :: Port
|
||||
, helloMsg :: HelloMsg
|
||||
}
|
||||
|
||||
{-|
|
||||
Our application will be able to have configuration from both a file and from
|
||||
command line input. We can use the command line to temporarily override the
|
||||
configuration from our file. But how to combine them? This question will help us
|
||||
find which abstraction is correct for our needs...
|
||||
|
||||
We want the CommandLine configuration to override the File configuration, so if
|
||||
we think about combining each of our config records, we want to be able to write
|
||||
something like this:
|
||||
|
||||
defaults <> file <> commandLine
|
||||
|
||||
The commandLine should override any options it has input for.
|
||||
|
||||
We can use the Monoid typeclass to handle combining the config records together,
|
||||
and the Last newtype to wrap up our values. The Last newtype is a wrapper for
|
||||
Maybe that when used with its Monoid instance will always preference the last
|
||||
Just value that it has:
|
||||
|
||||
Last (Just 3) <> Last (Just 1) = Last (Just 1)
|
||||
Last Nothing <> Last (Just 1) = Last (Just 1)
|
||||
Last (Just 1) <> Last Nothing = Last (Just 1)
|
||||
|
||||
To make this easier, we'll make a new record PartialConf that will have our Last
|
||||
wrapped values. We can then define a Monoid instance for it and have our Conf be
|
||||
a known good configuration.
|
||||
-}
|
||||
data PartialConf = PartialConf
|
||||
{ pcPort :: Last Port
|
||||
, pcHelloMsg :: Last HelloMsg
|
||||
}
|
||||
|
||||
{-|
|
||||
We now define our Monoid instance for PartialConf. Allowing us to define our
|
||||
always empty configuration, which would always fail our requirements. More
|
||||
interestingly, we define our mappend function to lean on the Monoid instance for
|
||||
Last to always get the last value.
|
||||
|
||||
Note that the types won't be able to completely save you here, if you mess up
|
||||
the ordering of your 'a' and 'b' you will not end up with the desired result.
|
||||
-}
|
||||
-- Note that the types won't be able to completely save you here, if you mess up
|
||||
-- the ordering of your 'a' and 'b' you will not end up with the desired result.
|
||||
instance Monoid PartialConf where
|
||||
mempty = PartialConf mempty mempty
|
||||
|
||||
@ -125,17 +79,12 @@ instance Monoid PartialConf where
|
||||
, pcHelloMsg = pcHelloMsg a <> pcHelloMsg b
|
||||
}
|
||||
|
||||
-- We have some sane defaults that we can always rely on, so define them using
|
||||
-- our PartialConf.
|
||||
defaultConf
|
||||
:: PartialConf
|
||||
defaultConf = PartialConf
|
||||
(pure (Port 3000))
|
||||
(pure (HelloMsg "World!"))
|
||||
|
||||
-- We need something that will take our PartialConf and see if can finally build
|
||||
-- a complete Conf record. Also we need to highlight any missing config values
|
||||
-- by providing the relevant error.
|
||||
makeConfig
|
||||
:: PartialConf
|
||||
-> Either ConfigError Conf
|
||||
@ -149,11 +98,6 @@ makeConfig pc = Conf
|
||||
lastToEither e g =
|
||||
maybe (Left e) Right . getLast $ g pc
|
||||
|
||||
-- This is the function we'll actually export for building our configuration.
|
||||
-- Since it wraps all our efforts to read information from the command line, and
|
||||
-- the file, before combining it all and returning the required information.
|
||||
--
|
||||
-- Additional Exercise: Rewrite this using applicative style.
|
||||
parseOptions
|
||||
:: FilePath
|
||||
-> IO (Either ConfigError Conf)
|
||||
@ -164,11 +108,8 @@ parseOptions fp = do
|
||||
|
||||
-- | File Parsing
|
||||
|
||||
-- Avoiding too many complications with selecting a configuration file package
|
||||
-- from hackage. We'll use an encoding that you are probably familiar with, for
|
||||
-- better or worse, and write a small parser to pull out the bits we need.
|
||||
--
|
||||
-- Additional Exercise: Rewrite this without using Do notation, fmap should be sufficient.
|
||||
-- Additional Exercise: Rewrite this without using Do notation
|
||||
-- 'fmap' should be sufficient.
|
||||
parseJSONConfigFile
|
||||
:: FilePath
|
||||
-> IO PartialConf
|
||||
@ -236,12 +177,7 @@ portParser =
|
||||
in
|
||||
Last <$> optional (option portReader mods)
|
||||
|
||||
-- Parse the HelloMsg from the input string into our type and into a Last
|
||||
-- wrapper.
|
||||
--
|
||||
-- Remember that newtypes have zero runtime cost, they are removed by the
|
||||
-- compiler. So don't be concerned by the wrapping / unwrapping of them in your
|
||||
-- code. They are there for the type system and you.
|
||||
-- Parse the HelloMsg from the input string into our type and into a Last wrapper.
|
||||
helloMsgParser
|
||||
:: Parser (Last HelloMsg)
|
||||
helloMsgParser =
|
||||
|
||||
@ -73,9 +73,9 @@ handleRequest
|
||||
handleRequest cfg (AddRq _ _) =
|
||||
Right $ resp200 (Conf.mkMessage cfg)
|
||||
handleRequest _ (ViewRq _) =
|
||||
Right $ resp200 "Susan was ere"
|
||||
Right $ resp200 "Susan was here"
|
||||
handleRequest _ ListRq =
|
||||
Right $ resp200 "[ \"Fred wuz ere\", \"Susan was ere\" ]"
|
||||
Right $ resp200 "[ \"Fred was here\", \"Susan was here\" ]"
|
||||
|
||||
mkRequest
|
||||
:: Request
|
||||
|
||||
@ -34,10 +34,6 @@ import Text.Read (readEither)
|
||||
|
||||
-- import FirstApp.DB (Table (..))
|
||||
|
||||
{-|
|
||||
Similar to when we were considering what might go wrong with the RqTypes, lets
|
||||
think about might go wrong when trying to gather our configuration information.
|
||||
-}
|
||||
data ConfigError
|
||||
= MissingPort
|
||||
| MissingHelloMsg
|
||||
@ -45,10 +41,6 @@ data ConfigError
|
||||
-- | MissingDbFilePath
|
||||
deriving Show
|
||||
|
||||
{-|
|
||||
As before, a bare Int or ByteString doesn't tell us anything about our intent,
|
||||
so lets wrap it up in a newtype.
|
||||
-}
|
||||
newtype Port = Port
|
||||
{ getPort :: Int }
|
||||
deriving Show
|
||||
@ -73,11 +65,7 @@ mkMessage =
|
||||
. getHelloMsg
|
||||
. helloMsg
|
||||
|
||||
{-|
|
||||
This will be our configuration value, eventually it may contain more things
|
||||
but this will do for now. We will have a customisable port number, and a
|
||||
changeable message for our users.
|
||||
-}
|
||||
|
||||
data Conf = Conf
|
||||
{ port :: Port
|
||||
, helloMsg :: HelloMsg
|
||||
@ -85,33 +73,6 @@ data Conf = Conf
|
||||
-- , dbFilePath :: FilePath
|
||||
}
|
||||
|
||||
{-|
|
||||
Our application will be able to have configuration from both a file and from
|
||||
command line input. We can use the command line to temporarily override the
|
||||
configuration from our file. But how to combine them? This question will help us
|
||||
find which abstraction is correct for our needs...
|
||||
|
||||
We want the CommandLine configuration to override the File configuration, so if
|
||||
we think about combining each of our config records, we want to be able to write
|
||||
something like this:
|
||||
|
||||
defaults <> file <> commandLine
|
||||
|
||||
The commandLine should override any options it has input for.
|
||||
|
||||
We can use the Monoid typeclass to handle combining the config records together,
|
||||
and the Last newtype to wrap up our values. The Last newtype is a wrapper for
|
||||
Maybe that when used with its Monoid instance will always preference the last
|
||||
Just value that it has:
|
||||
|
||||
Last (Just 3) <> Last (Just 1) = Last (Just 1)
|
||||
Last Nothing <> Last (Just 1) = Last (Just 1)
|
||||
Last (Just 1) <> Last Nothing = Last (Just 1)
|
||||
|
||||
To make this easier, we'll make a new record PartialConf that will have our Last
|
||||
wrapped values. We can then define a Monoid instance for it and have our Conf be
|
||||
a known good configuration.
|
||||
-}
|
||||
data PartialConf = PartialConf
|
||||
{ pcPort :: Last Port
|
||||
, pcHelloMsg :: Last HelloMsg
|
||||
@ -119,17 +80,10 @@ data PartialConf = PartialConf
|
||||
-- , pcDbFilePath :: Last FilePath
|
||||
}
|
||||
|
||||
{-|
|
||||
We now define our Monoid instance for PartialConf. Allowing us to define our
|
||||
always empty configuration, which would always fail our requirements. More
|
||||
interestingly, we define our mappend function to lean on the Monoid instance for
|
||||
Last to always get the last value.
|
||||
|
||||
Note that the types won't be able to completely save you here, if you mess up
|
||||
the ordering of your 'a' and 'b' you will not end up with the desired result.
|
||||
-}
|
||||
-- Note that the types won't be able to completely save you here, if you mess up
|
||||
-- the ordering of your 'a' and 'b' you will not end up with the desired result.
|
||||
instance Monoid PartialConf where
|
||||
mempty = PartialConf mempty mempty
|
||||
mempty = PartialConf mempty mempty
|
||||
|
||||
mappend a b = PartialConf
|
||||
-- Compiler tells us about the little things we might have forgotten.
|
||||
@ -149,9 +103,6 @@ defaultConf = PartialConf
|
||||
-- (pure (Table "comments"))
|
||||
-- (pure "firstapp_db.db")
|
||||
|
||||
-- We need something that will take our PartialConf and see if can finally build
|
||||
-- a complete Conf record. Also we need to highlight any missing config values
|
||||
-- by providing the relevant error.
|
||||
makeConfig
|
||||
:: PartialConf
|
||||
-> Either ConfigError Conf
|
||||
@ -167,11 +118,6 @@ makeConfig pc = Conf
|
||||
lastToEither e g =
|
||||
maybe (Left e) Right . getLast $ g pc
|
||||
|
||||
-- This is the function we'll actually export for building our configuration.
|
||||
-- Since it wraps all our efforts to read information from the command line, and
|
||||
-- the file, before combining it all and returning the required information.
|
||||
--
|
||||
-- Additional Exercise: Rewrite this using applicative style.
|
||||
parseOptions
|
||||
:: FilePath
|
||||
-> IO (Either ConfigError Conf)
|
||||
@ -182,11 +128,6 @@ parseOptions fp = do
|
||||
|
||||
-- | File Parsing
|
||||
|
||||
-- Avoiding too many complications with selecting a configuration file package
|
||||
-- from hackage. We'll use an encoding that you are probably familiar with, for
|
||||
-- better or worse, and write a small parser to pull out the bits we need.
|
||||
--
|
||||
-- Additional Exercise: Rewrite this without using Do notation, fmap should be sufficient.
|
||||
parseJSONConfigFile
|
||||
:: FilePath
|
||||
-> IO PartialConf
|
||||
@ -225,9 +166,6 @@ parseJSONConfigFile fp = do
|
||||
|
||||
-- | Command Line Parsing
|
||||
|
||||
-- We will use the optparse-applicative package to build our command line
|
||||
-- parser, as this problem is fraught with silly dangers and we appreciate
|
||||
-- someone else having eaten this gremlin on our behalf.
|
||||
commandLineParser
|
||||
:: ParserInfo PartialConf
|
||||
commandLineParser =
|
||||
@ -242,33 +180,25 @@ partialConfParser
|
||||
:: Parser PartialConf
|
||||
partialConfParser = PartialConf
|
||||
<$> portParser
|
||||
<*> strParse helloFromStr helloMods
|
||||
<*> (Last <$> optional (helloFromStr <$> strOption helloMods)
|
||||
-- Add our two new fields to the parsing of the PartialConf record. Note that
|
||||
-- if you update the data structure the compiler will do its best to inform
|
||||
-- you about everywhere that needs attention.
|
||||
-- <*> strParse ( Table . Text.pack ) tableMods
|
||||
-- <*> strParse id dbFilePathMods
|
||||
where
|
||||
-- With the addition of two new very similar parsers, we can abstract out
|
||||
-- part of the construction into a separate function so we avoid repeating
|
||||
-- ourselves.
|
||||
strParse c m =
|
||||
Last <$> optional (c <$> strOption m)
|
||||
|
||||
helloMods = long "hello-msg"
|
||||
<> short 'm'
|
||||
<> metavar "HELLOMSG"
|
||||
<> help "Message to respond to requests with."
|
||||
|
||||
-- dbFilePathMods = long "db-filepath"
|
||||
-- <> short 'd'
|
||||
-- <> metavar "DBFILEPATH"
|
||||
-- <> help "FilePath to the SQLite DB"
|
||||
dbFilePathMods = long "db-filepath"
|
||||
<> short 'd'
|
||||
<> metavar "DBFILEPATH"
|
||||
<> help "FilePath to the SQLite DB"
|
||||
|
||||
-- tableMods = long "table-name"
|
||||
-- <> short 't'
|
||||
-- <> metavar "TABLENAME"
|
||||
-- <> help "Comments DB table name"
|
||||
tableMods = long "table-name"
|
||||
<> short 't'
|
||||
<> metavar "TABLENAME"
|
||||
<> help "Comments DB table name"
|
||||
|
||||
-- Parse the Port value off the command line args and into our Last wrapper.
|
||||
portParser
|
||||
|
||||
@ -23,19 +23,20 @@ import Database.SQLite.SimpleErrors.Types (SQLiteResponse)
|
||||
|
||||
import FirstApp.Types
|
||||
|
||||
-- newtype all the things!!
|
||||
-- newtype Table = Table
|
||||
-- { getTableName :: Text }
|
||||
-- deriving Show
|
||||
-- ------------------------------------------------------------------------|
|
||||
-- You'll need the documentation for sqlite-simple ready for this section! |
|
||||
-- ------------------------------------------------------------------------|
|
||||
|
||||
-- We need to have a way to pass around the name of the Table we're going to us
|
||||
-- for the comments in this application. We _could_ just pass around a `Text`
|
||||
-- value. What should we do instead?
|
||||
newtype Table
|
||||
|
||||
-- We have a data type to simplify passing around the information we need to run
|
||||
-- our database queries. This also allows things to change over time without
|
||||
-- having to rewrite all of the functions that need to interact with DB related
|
||||
-- things in different ways.
|
||||
data FirstAppDB = FirstAppDB
|
||||
-- { dbConn :: Connection
|
||||
-- , dbTable :: Table
|
||||
-- }
|
||||
data FirstAppDB
|
||||
|
||||
-- Quick helper to pull the connection and close it down.
|
||||
closeDb
|
||||
@ -43,62 +44,35 @@ closeDb
|
||||
-> IO ()
|
||||
closeDb =
|
||||
error "closeDb not implemented"
|
||||
-- Sql.close . dbConn
|
||||
|
||||
-- Due to the way our application is designed, we have a slight SQL injection
|
||||
-- risk because we pull the table name from the config or input arguments. This
|
||||
-- attempts to mitigate that somewhat by removing the need for repetitive string
|
||||
-- mangling when building our queries. We simply write the query and pass it
|
||||
-- through this function that requires the Table information and everything is
|
||||
-- taken care of for us. This is probably not the way to do things in a large
|
||||
-- scale app.
|
||||
-- risk because we pull the Table name from the Conf. Write a function that
|
||||
-- attempts to mitigate that risk a bit, by handling replacement of a placeholder value
|
||||
-- in a given Query. We should be able to write the query and pass it through this
|
||||
-- function and everything is will be taken care of for us.
|
||||
|
||||
-- This is not the way to do things in a large scale app, obviously.
|
||||
withTable
|
||||
:: Table
|
||||
-> Query
|
||||
-> Query
|
||||
withTable t =
|
||||
error "withTable not yet implemented"
|
||||
-- Sql.Query
|
||||
-- . Text.replace "$$tablename$$" (getTableName t)
|
||||
-- . fromQuery
|
||||
|
||||
-- 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
|
||||
-> Table
|
||||
-> IO ( Either SQLiteResponse FirstAppDB )
|
||||
initDb fp tab =
|
||||
error "initDb not implemented"
|
||||
-- Sql.runDBAction $ do
|
||||
-- Initialise the connection to the DB...
|
||||
-- - What could go wrong here?
|
||||
-- - What haven't we be told in the types?
|
||||
-- con <- Sql.open fp
|
||||
-- Initialise our one table, if it's not there already
|
||||
-- _ <- Sql.execute_ con createTableQ
|
||||
-- pure $ FirstAppDB con tab
|
||||
-- where
|
||||
where
|
||||
-- Query has a IsString instance so you can write straight strings like this
|
||||
-- and it will convert them into a Query type, use '?' as placeholders for
|
||||
-- ORDER DEPENDENT interpolation.
|
||||
-- createTableQ = withTable tab
|
||||
-- "CREATE TABLE IF NOT EXISTS $$tablename$$ (id INTEGER PRIMARY KEY, topic TEXT, comment TEXT, time INTEGER)"
|
||||
|
||||
runDb
|
||||
:: (a -> Either Error b)
|
||||
-> IO a
|
||||
-> IO (Either Error b)
|
||||
runDb f a =
|
||||
error "runDb not implemented"
|
||||
-- do
|
||||
-- r <- Sql.runDBAction a
|
||||
-- pure $ either (Left . DBError) f r
|
||||
-- Choices, choices...
|
||||
-- Sql.runDBAction a >>= pure . either (Left . DBError) f
|
||||
-- these two are pretty much the same.
|
||||
-- Sql.runDBAction >=> pure . either (Left . DBError) f
|
||||
-- this is because we noticed that our call to pure, which means we should
|
||||
-- just be able to fmap to victory.
|
||||
-- fmap ( either (Left . DBError) f ) . Sql.runDBAction
|
||||
createTableQ = withTable tab
|
||||
"CREATE TABLE IF NOT EXISTS $$tablename$$ (id INTEGER PRIMARY KEY, topic TEXT, comment TEXT, time INTEGER)"
|
||||
|
||||
getComments
|
||||
:: FirstAppDB
|
||||
@ -106,14 +80,6 @@ getComments
|
||||
-> IO (Either Error [Comment])
|
||||
getComments db t =
|
||||
error "getComments not implemented"
|
||||
-- do
|
||||
-- Write the query with an icky string and remember your placeholders!
|
||||
-- let q = withTable (dbTable db)
|
||||
-- "SELECT id,topic,comment,time FROM $$tablename$$ WHERE topic = ?"
|
||||
-- To be doubly and triply sure we've no garbage in our response, we take care
|
||||
-- to convert our DB storage type into something we're going to share with the
|
||||
-- outside world. Checking again for things like empty Topic or CommentText values.
|
||||
-- runDb ( traverse fromDbComment ) $ Sql.query (dbConn db) q [ getTopic t ]
|
||||
|
||||
addCommentToTopic
|
||||
:: FirstAppDB
|
||||
@ -122,31 +88,12 @@ addCommentToTopic
|
||||
-> IO (Either Error ())
|
||||
addCommentToTopic db t c =
|
||||
error "addCommentToTopic not implemented"
|
||||
-- do
|
||||
-- Record the time this comment was created.
|
||||
-- nowish <- getCurrentTime
|
||||
-- Note the triple, matching the number of values we're trying to insert, plus
|
||||
-- one for the table name.
|
||||
-- let q = withTable (dbTable db)
|
||||
-- Remember that the '?' are order dependent so if you get your input
|
||||
-- parameters in the wrong order, the types won't save you here. More on that
|
||||
-- sort of goodness later.
|
||||
-- "INSERT INTO $$tablename$$ (topic,comment,time) VALUES (?,?,?)"
|
||||
-- We use the execute function this time as we don't care about anything
|
||||
-- that is returned. The execute function will still return the number of rows
|
||||
-- affected by the query, which in our case should always be 1.
|
||||
-- runDb Right $ Sql.execute (dbConn db) q (getTopic t, getCommentText c, nowish)
|
||||
-- An alternative is to write a returning query to get the Id of the DbComment
|
||||
-- we've created. We're being lazy (hah!) for now, so assume awesome and move on.
|
||||
|
||||
getTopics
|
||||
:: FirstAppDB
|
||||
-> IO (Either Error [Topic])
|
||||
getTopics db =
|
||||
error "getTopics not implemented"
|
||||
-- let q = withTable (dbTable db) "SELECT DISTINCT topic FROM $$tablename$$"
|
||||
-- in
|
||||
-- runDb (traverse ( mkTopic . Sql.fromOnly )) $ Sql.query_ (dbConn db) q
|
||||
|
||||
deleteTopic
|
||||
:: FirstAppDB
|
||||
@ -154,6 +101,3 @@ deleteTopic
|
||||
-> IO (Either Error ())
|
||||
deleteTopic db t =
|
||||
error "deleteTopic not implemented"
|
||||
-- let q = withTable (dbTable db) "DELETE FROM $$tablename$$ WHERE topic = ?"
|
||||
-- in
|
||||
-- runDb Right $ Sql.execute (dbConn db) q [getTopic t]
|
||||
|
||||
@ -44,47 +44,12 @@ data StartUpError
|
||||
runApp :: IO ()
|
||||
runApp = do
|
||||
appE <- prepareAppReqs
|
||||
error "runApp not re-implemented"
|
||||
-- either print runWithDbConn appE
|
||||
-- where
|
||||
-- runWithDbConn ( cfg, db ) =
|
||||
-- -- The bracket function will take care of closing our DB connection in the
|
||||
-- -- event of an application collapse. It is a very useful function for
|
||||
-- -- managing resources and deferred actions.
|
||||
-- bracket (pure db) DB.closeDb (appWithDb cfg)
|
||||
|
||||
-- appWithDb cfg db =
|
||||
-- -- Just a helper to actually use the Wai function to run out fully
|
||||
-- -- realised app function.
|
||||
-- run ( Conf.getPort $ Conf.port cfg ) $ app cfg db
|
||||
_f appE
|
||||
|
||||
prepareAppReqs
|
||||
:: IO (Either StartUpError (Conf.Conf,DB.FirstAppDB))
|
||||
prepareAppReqs = do
|
||||
error "prepareAppReqs not implemented"
|
||||
-- cfgE <- initConf
|
||||
-- -- This is awkward because we need to initialise our DB using the config,
|
||||
-- -- which might have failed to be created for some reason, but our DB start up
|
||||
-- -- might have also failed for some reason. This is a bit clunky
|
||||
-- dbE <- fmap join $ traverse initDB cfgE
|
||||
-- -- Wrap our values (if we have them) in a tuple for use in other parts of our
|
||||
-- -- application. We do it this way so we can have access to the bits we need
|
||||
-- -- when starting up the full app or one for testing.
|
||||
-- pure $ liftA2 (,) cfgE dbE
|
||||
-- where
|
||||
-- toStartUpErr e =
|
||||
-- -- This just makes it a bit easier to take our individual initialisation
|
||||
-- -- functions and ensure that they both conform to the StartUpError type
|
||||
-- -- that we want them too.
|
||||
-- fmap ( either (Left . e) Right )
|
||||
|
||||
-- initConf = toStartUpErr ConfErr
|
||||
-- -- Prepare the configgening
|
||||
-- $ Conf.parseOptions "appconfig.json"
|
||||
|
||||
-- initDB cfg = toStartUpErr DbInitErr
|
||||
-- -- Power up the tubes
|
||||
-- $ DB.initDb (Conf.dbFilePath cfg) (Conf.tableName cfg)
|
||||
|
||||
-- | Just some helper functions to make our lives a little more DRY.
|
||||
mkResponse
|
||||
@ -150,18 +115,9 @@ handleRequest
|
||||
-> DB.FirstAppDB
|
||||
-> RqType
|
||||
-> IO (Either Error Response)
|
||||
-- Fun time to play with some type driven development. Try inserting a
|
||||
-- type-hole on the left of the getComments function call and see what sort of
|
||||
-- functions you need to produce the desired output. See how well you can
|
||||
-- reduce the function you need to write with the application of abstractions
|
||||
-- you already know, no custom functions.
|
||||
handleRequest _ db (AddRq t c) =
|
||||
-- How could we eliminate the need for `const` here?
|
||||
fmap (const ( resp200 "Success" )) <$> error "db func not implemented" -- DB.addCommentToTopic db t c
|
||||
handleRequest _ db (ViewRq t) =
|
||||
fmap resp200Json <$> error "db func not implemented" -- DB.getComments db t
|
||||
handleRequest _ db ListRq =
|
||||
fmap resp200Json <$> error "db func not implemented" -- DB.getTopics db
|
||||
handleRequest _ db (AddRq t c) = fmap (const ( resp200 "Success" )) <$> _f db
|
||||
handleRequest _ db (ViewRq t) = fmap resp200Json <$> _g db
|
||||
handleRequest _ db ListRq = fmap resp200Json <$> _h db
|
||||
|
||||
mkRequest
|
||||
:: Request
|
||||
@ -210,7 +166,3 @@ mkErrorResponse EmptyCommentText =
|
||||
resp400 "Empty Comment"
|
||||
mkErrorResponse EmptyTopic =
|
||||
resp400 "Empty Topic"
|
||||
-- mkErrorResponse ( DBError e ) =
|
||||
-- If a DB error happens, it's going to be sad town, population you. But you
|
||||
-- should let someone know. How we go about changing this function to include logging ?
|
||||
-- resp500 . LBS.pack $ "Database Error" <> show e
|
||||
|
||||
@ -30,59 +30,41 @@ import qualified Data.Aeson.Types as A
|
||||
|
||||
import Data.Time (UTCTime)
|
||||
|
||||
-- import Database.SQLite.SimpleErrors.Types (SQLiteResponse)
|
||||
-- import FirstApp.Types.DB (DbComment (..))
|
||||
|
||||
{-|
|
||||
In Haskell the `newtype` comes with zero runtime cost. It is purely used for
|
||||
typechecking. So when you have a bare 'primitive' value, like an Int, String, or
|
||||
even [a], you can wrap it up in a `newtype` for clarity.
|
||||
|
||||
The type system will check it for you, and the compiler will eliminate the cost
|
||||
once it has passed.
|
||||
-}
|
||||
newtype CommentId = CommentId Int
|
||||
deriving (Show, ToJSON)
|
||||
|
||||
newtype Topic = Topic { getTopic :: Text }
|
||||
deriving (Show, ToJSON)
|
||||
|
||||
newtype CommentText = CommentText { getCommentText :: Text }
|
||||
deriving (Show, ToJSON)
|
||||
|
||||
-- This is our comment record that we will be sending to users, it's a simple
|
||||
-- record type. However notice that we've also derived the Generic type class
|
||||
-- instance as well. This saves us some effort when it comes to creating
|
||||
-- encoding/decoding instances. Since our types are all simple types at the end
|
||||
-- of the day, we're able to just let GHC work out what the instances should be.
|
||||
-- With a minor adjustment.
|
||||
data Comment = Comment
|
||||
-- { commentId :: CommentId
|
||||
-- , commentTopic :: Topic
|
||||
-- , commentText :: CommentText
|
||||
-- , commentTime :: UTCTime
|
||||
-- }
|
||||
-- Generic has been added to our deriving list.
|
||||
-- This is the Comment record that we will be sending to users, it's a simple
|
||||
-- record type, containing an Int, Topic, CommentText, and UTCTime. However notice
|
||||
-- that we've also derived the Generic type class instance as well. This saves us
|
||||
-- some effort when it comes to creating encoding/decoding instances. Since our
|
||||
-- types are all simple types at the end of the day, we're able to just let GHC do
|
||||
-- the work.
|
||||
--
|
||||
-- Is an 'Int' acceptable here?
|
||||
data Comment = Comment { ... }
|
||||
deriving ( Show, Generic )
|
||||
|
||||
instance ToJSON Comment where
|
||||
-- This is one place where we can take advantage of our Generic instance. Aeson already has the encoding functions written for anything that implements the Generic typeclass. So we don't have to write our encoding, we just tell Aeson to build it.
|
||||
-- toEncoding = A.genericToEncoding opts
|
||||
-- This is one place where we can take advantage of our Generic instance. Aeson
|
||||
-- already has the encoding functions written for anything that implements
|
||||
-- the Generic typeclass. So we don't have to write our encoding, we just ask
|
||||
-- Aeson to construct it for us.
|
||||
toEncoding = A.genericToEncoding opts
|
||||
where
|
||||
-- These options let us make some minor adjustments to how Aeson treats
|
||||
-- our type. Our only adjustment is to alter the field names a little, to
|
||||
-- remove the 'comment' prefix and camel case what is left of the name.
|
||||
-- This accepts any 'String -> String' function but it's good to keep the
|
||||
-- modifications simple.
|
||||
-- opts = A.defaultOptions
|
||||
-- { A.fieldLabelModifier = modFieldLabel
|
||||
-- }
|
||||
|
||||
opts = A.defaultOptions
|
||||
{ A.fieldLabelModifier = modFieldLabel
|
||||
}
|
||||
-- Strip the prefix (which may fail if the prefix isn't present), fall
|
||||
-- back to the original label if need be, then camel-case the name.
|
||||
-- modFieldLabel l =
|
||||
-- A.camelTo2 '_' . fromMaybe l
|
||||
-- $ stripPrefix "comment" l
|
||||
modFieldLabel l = error "modFieldLabel not implemented"
|
||||
|
||||
-- For safety we take our stored DbComment and try to construct a Comment that
|
||||
-- we would be okay with showing someone. However unlikely it may be, this is a
|
||||
@ -93,10 +75,6 @@ fromDbComment
|
||||
-> Either Error Comment
|
||||
fromDbComment dbc =
|
||||
error "fromDbComment not yet implemented"
|
||||
-- Comment (CommentId $ dbCommentId dbc)
|
||||
-- <$> (mkTopic $ dbCommentTopic dbc)
|
||||
-- <*> (mkCommentText $ dbCommentComment dbc)
|
||||
-- <*> pure (dbCommentTime dbc)
|
||||
|
||||
-- Having specialised constructor functions for the newtypes allows you to set
|
||||
-- restrictions for your newtype.
|
||||
@ -125,14 +103,6 @@ data RqType
|
||||
| ViewRq Topic
|
||||
| ListRq
|
||||
|
||||
{-|
|
||||
Not everything goes according to plan, but it's important that our
|
||||
types reflect when errors can be introduced into our program. Additionally
|
||||
it's useful to be able to be descriptive about what went wrong.
|
||||
|
||||
So lets think about some of the basic things that can wrong with our
|
||||
program and create some values to represent that.
|
||||
-}
|
||||
data Error
|
||||
= UnknownRoute
|
||||
| EmptyCommentText
|
||||
@ -140,8 +110,6 @@ data Error
|
||||
-- | DBError SQLiteResponse
|
||||
deriving Show
|
||||
|
||||
-- Provide a type to list our response content types so we don't try to
|
||||
-- do the wrong thing with what we meant to be used as text/JSON etc.
|
||||
data ContentType
|
||||
= PlainText
|
||||
| JSON
|
||||
@ -152,6 +120,5 @@ data ContentType
|
||||
renderContentType
|
||||
:: ContentType
|
||||
-> ByteString
|
||||
-- renderContentType = error "renderContentType not implemented"
|
||||
renderContentType PlainText = "text/plain"
|
||||
renderContentType JSON = "text/json"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user