From 64ef56f72871656159bc5b4f197c952b7ac73e28 Mon Sep 17 00:00:00 2001 From: Sean Chalmers Date: Mon, 20 Nov 2023 13:20:18 +0000 Subject: [PATCH 1/2] Remove waargonaut and revert to using aeson. waargonaut is a bit too fancy, not as widely supported and has an overly complex build process. --- applied-fp-course.cabal | 3 +- flake.nix | 10 +++-- src/Level04/Core.hs | 16 +++---- src/Level04/Types.hs | 23 +++------- src/Level04/Types/CommentText.hs | 9 ++-- src/Level04/Types/Topic.hs | 42 ++++--------------- src/Level05/Core.hs | 17 ++++---- src/Level05/Types.hs | 37 ++++++---------- src/Level05/Types/CommentText.hs | 14 +++---- src/Level05/Types/Topic.hs | 13 +++--- src/Level06/Conf/File.hs | 6 +-- src/Level06/Core.hs | 25 +++++------ src/Level06/Types.hs | 58 ++++++++++--------------- src/Level06/Types/CommentText.hs | 14 +++---- src/Level06/Types/Topic.hs | 13 +++--- src/Level07/Conf/File.hs | 19 ++++----- src/Level07/Core.hs | 7 +--- src/Level07/Responses.hs | 14 +++---- src/Level07/Types.hs | 72 +++++++++++++++----------------- src/Level07/Types/CommentText.hs | 14 +++---- src/Level07/Types/Topic.hs | 13 +++--- 21 files changed, 161 insertions(+), 278 deletions(-) diff --git a/applied-fp-course.cabal b/applied-fp-course.cabal index 805934f1..20275a24 100644 --- a/applied-fp-course.cabal +++ b/applied-fp-course.cabal @@ -86,9 +86,10 @@ library , text ^>=1.2 , time >=1.4 && <1.10 , transformers >=0.4 && <0.6 - , waargonaut >=0.6 && <0.9 , wai >=3.2 && <3.4 , warp >=3.2 && <3.4 + , aeson >=1.5 && <3 + , scientific >=0.3 && <0.4 -- Directories containing source files. hs-source-dirs: src diff --git a/flake.nix b/flake.nix index 4d9c4c57..a37c1f30 100644 --- a/flake.nix +++ b/flake.nix @@ -20,12 +20,12 @@ root = ./.; overrides = final: prev: with nixpkgs.haskell.lib; { - hw-json-simd = dontCheck (unmarkBroken prev.hw-json-simd); - hw-json-standard-cursor = doJailbreak prev.hw-json-standard-cursor; - natural = dontCheck (unmarkBroken prev.natural); + # hw-json-simd = dontCheck (unmarkBroken prev.hw-json-simd); + # hw-json-standard-cursor = doJailbreak prev.hw-json-standard-cursor; + # natural = dontCheck (unmarkBroken prev.natural); sqlite-simple-errors = unmarkBroken (doJailbreak prev.sqlite-simple-errors); - waargonaut = dontCheck (doJailbreak prev.waargonaut); + # waargonaut = dontCheck (doJailbreak prev.waargonaut); }; }; in @@ -37,6 +37,8 @@ nixpkgs.cabal-install nixpkgs.ghcid nixpkgs.sqlite + + nixpkgs.stylish-haskell ]; }); }); diff --git a/src/Level04/Core.hs b/src/Level04/Core.hs index 158c70e6..924ebbea 100644 --- a/src/Level04/Core.hs +++ b/src/Level04/Core.hs @@ -14,12 +14,12 @@ import Network.Wai (Application, Request, strictRequestBody) import Network.Wai.Handler.Warp (run) +import Data.Aeson (ToJSON, encode) +import qualified Data.ByteString.Lazy.Char8 as LBS 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) @@ -30,9 +30,6 @@ 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), @@ -102,12 +99,11 @@ resp500 = mkResponse status500 resp200Json - :: Encoder' a - -> a + :: ToJSON a + => a -> Response -resp200Json e = - mkResponse status200 JSON . encodeUtf8 . - E.simplePureEncodeTextNoSpaces e +resp200Json = + mkResponse status200 JSON . encode -- | app diff --git a/src/Level04/Types.hs b/src/Level04/Types.hs index 68de2a37..c7f8c8ea 100644 --- a/src/Level04/Types.hs +++ b/src/Level04/Types.hs @@ -16,6 +16,8 @@ module Level04.Types , fromDBComment ) where +import Data.Aeson (ToJSON (..)) + import GHC.Generics (Generic) import Data.ByteString (ByteString) @@ -24,14 +26,9 @@ import Data.Text (Text, pack) import Data.List (stripPrefix) import Data.Maybe (fromMaybe) -import Data.Functor.Contravariant ((>$<)) - 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) -- | Notice how we've moved these types into their own modules. It's cheap and @@ -60,15 +57,13 @@ data Comment = Comment deriving Show -- | We're going to write the JSON encoder for our `Comment` type. We'll need to --- consult the documentation in the 'Waargonaut.Encode' module to find the +-- consult the documentation in the 'Aeson' package to find the -- relevant functions and instructions on how to use them: -- --- 'https://hackage.haskell.org/package/waargonaut/docs/Waargonaut-Encode.html' +-- 'https://hackage.haskell.org/package/aeson/docs/Data-Aeson.html' -- -encodeComment :: Applicative f => Encoder f Comment -encodeComment = - error "Comment JSON encoder not implemented" - -- Tip: Use the 'encodeISO8601DateTime' to handle the UTCTime for us. +instance ToJSON Comment where + toJSON = error "Comment ToJSON instance no 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 @@ -95,10 +90,4 @@ renderContentType renderContentType PlainText = "text/plain" renderContentType JSON = "application/json" -encodeISO8601DateTime :: Applicative f => Encoder f UTCTime -encodeISO8601DateTime = pack . TF.formatTime loc fmt >$< E.text - where - fmt = TF.iso8601DateFormat (Just "%H:%M:%S") - loc = TF.defaultTimeLocale { TF.knownTimeZones = [] } - -- | Move on to ``src/Level04/DB.hs`` next. diff --git a/src/Level04/Types/CommentText.hs b/src/Level04/Types/CommentText.hs index 865ebba8..272086ee 100644 --- a/src/Level04/Types/CommentText.hs +++ b/src/Level04/Types/CommentText.hs @@ -4,13 +4,11 @@ module Level04.Types.CommentText , getCommentText ) where -import Waargonaut.Encode (Encoder) -import qualified Waargonaut.Encode as E +import Data.Aeson (ToJSON (..)) import Level04.Types.Error (Error (EmptyCommentText), nonEmptyText) -import Data.Functor.Contravariant (contramap) import Data.Text (Text) newtype CommentText = CommentText Text @@ -52,6 +50,5 @@ getCommentText (CommentText t) = -- functions. There is a quick introduction to `Contravariant` in the `README` -- for this level. -- -encodeCommentText :: Applicative f => Encoder f CommentText -encodeCommentText = -- Try using 'contramap' and 'E.text'. - error "CommentText JSON encoder not implemented" +instance ToJSON CommentText where + toJSON = error "CommentText JSON encoder not implemented" diff --git a/src/Level04/Types/Topic.hs b/src/Level04/Types/Topic.hs index d81c5c1c..1e19483c 100644 --- a/src/Level04/Types/Topic.hs +++ b/src/Level04/Types/Topic.hs @@ -2,11 +2,9 @@ module Level04.Types.Topic ( Topic , mkTopic , getTopic - , encodeTopic ) where -import Waargonaut.Encode (Encoder) -import qualified Waargonaut.Encode as E +import Data.Aeson (ToJSON (..)) import Data.Functor.Contravariant (contramap) import Data.Text (Text) @@ -28,37 +26,11 @@ getTopic getTopic (Topic t) = t --- | We will use this function to describe how we would like our `Topic` --- type to be encoded into JSON. +-- | We're going to write the JSON encoder for our `Topic` type. We'll need to consult the +-- documentation in the 'Aeson' package to find the relevant functions and instructions on how to +-- use them: -- --- Waargonaut knows how to encode a `Text` value, we need a way of telling it --- how to unwrap our newtype to encode the `Text` value inside. +-- 'https://hackage.haskell.org/package/aeson/docs/Data-Aeson.html' -- --- We _could_ write the code to unpack or pattern match on the `Topic` and --- then run the `Text` encoder using that value as input before returning that --- as the result of our Encoder. Something like this: --- --- @ --- encodeA $ \(Topic t) -> runEncoder text t --- @ --- --- But like many of the tasks that we've been completing in this course, the --- plumbing for such a thing has already been written for us. Sometimes the --- instances of the structure we're trying to create may provide a handy --- shortcut. --- --- In this case the `Encoder` type has an instance of `Contravariant`. Which has --- the following function: --- --- @ --- contramap :: Contravariant f => (a -> b) -> f b -> f a --- @ --- --- In this case the `Encoder` type has an instance of `Contravariant`. That --- 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" +instance ToJSON Topic where + toJSON = error "Topic ToJSON instance no implemented" diff --git a/src/Level05/Core.hs b/src/Level05/Core.hs index c437ed97..f01b2c34 100644 --- a/src/Level05/Core.hs +++ b/src/Level05/Core.hs @@ -28,8 +28,7 @@ import Data.Text (Text) import Data.Text.Encoding (decodeUtf8) import Data.Text.Lazy.Encoding (encodeUtf8) -import Waargonaut.Encode (Encoder') -import qualified Waargonaut.Encode as E +import Data.Aeson (ToJSON, encode) import Database.SQLite.SimpleErrors.Types (SQLiteResponse) @@ -39,7 +38,6 @@ import qualified Level05.DB as DB import Level05.Types (ContentType (..), Error (..), RqType (AddRq, ListRq, ViewRq), - encodeComment, encodeTopic, mkCommentText, mkTopic, renderContentType) @@ -116,12 +114,11 @@ resp500 = mkResponse status500 resp200Json - :: Encoder' a - -> a + :: ToJSON a + => a -> Response -resp200Json e = - resp200 JSON . encodeUtf8 . - E.simplePureEncodeTextNoSpaces e +resp200Json = + resp200 JSON . encode -- | @@ -142,8 +139,8 @@ handleRequest db rqType = case rqType of -- handles all of that for us. Such is the pleasant nature of these -- abstractions. AddRq t c -> resp200 PlainText "Success" <$ DB.addCommentToTopic db t c - ViewRq t -> resp200Json (E.list encodeComment) <$> DB.getComments db t - ListRq -> resp200Json (E.list encodeTopic) <$> DB.getTopics db + ViewRq t -> resp200Json <$> DB.getComments db t + ListRq -> resp200Json <$> DB.getTopics db mkRequest :: Request diff --git a/src/Level05/Types.hs b/src/Level05/Types.hs index 8c8b5cac..dce8cf61 100644 --- a/src/Level05/Types.hs +++ b/src/Level05/Types.hs @@ -15,8 +15,6 @@ module Level05.Types , getCommentText , renderContentType , fromDBComment - , encodeComment - , encodeTopic ) where import GHC.Generics (Generic) @@ -25,12 +23,11 @@ import GHC.Word (Word16) import Data.ByteString (ByteString) import Data.Text (Text, pack) -import System.IO.Error (IOError) - -import Data.Functor.Contravariant ((>$<)) +import Data.Aeson (ToJSON (..), object, (.=)) import Data.Monoid (Last, Monoid (mappend, mempty)) import Data.Semigroup (Semigroup ((<>))) +import System.IO.Error (IOError) import Data.List (stripPrefix) import Data.Maybe (fromMaybe) @@ -39,24 +36,19 @@ import qualified Data.Time.Format as TF import Database.SQLite.SimpleErrors.Types (SQLiteResponse) -import Waargonaut.Encode (Encoder) -import qualified Waargonaut.Encode as E - import Level05.DB.Types (DBComment (dbCommentComment, dbCommentId, dbCommentTime, dbCommentTopic)) import Level05.Types.CommentText (CommentText, - encodeCommentText, getCommentText, mkCommentText) import Level05.Types.Error (Error (DBError, EmptyCommentText, EmptyTopic, UnknownRoute)) -import Level05.Types.Topic (Topic, encodeTopic, - getTopic, mkTopic) +import Level05.Types.Topic (Topic, getTopic, mkTopic) newtype CommentId = CommentId Int deriving (Show) -encodeCommentId :: Applicative f => Encoder f CommentId -encodeCommentId = (\(CommentId i) -> i) >$< E.int +instance ToJSON CommentId where + toJSON (CommentId i) = toJSON i data Comment = Comment { commentId :: CommentId @@ -66,18 +58,13 @@ data Comment = Comment } deriving Show -encodeISO8601DateTime :: Applicative f => Encoder f UTCTime -encodeISO8601DateTime = pack . TF.formatTime tl fmt >$< E.text - where - fmt = TF.iso8601DateFormat (Just "%H:%M:%S") - tl = TF.defaultTimeLocale { TF.knownTimeZones = [] } - -encodeComment :: Applicative f => Encoder f Comment -encodeComment = E.mapLikeObj $ \c -> - E.atKey' "id" encodeCommentId (commentId c) . - E.atKey' "topic" encodeTopic (commentTopic c) . - E.atKey' "text" encodeCommentText (commentText c) . - E.atKey' "time" encodeISO8601DateTime (commentTime c) +instance ToJSON Comment where + toJSON c = object + [ "id" .= (commentId c) + , "topic" .= (commentTopic c) + , "text" .= (commentText c) + , "time" .= (commentTime c) + ] -- 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 diff --git a/src/Level05/Types/CommentText.hs b/src/Level05/Types/CommentText.hs index db37c599..8bdaa8c4 100644 --- a/src/Level05/Types/CommentText.hs +++ b/src/Level05/Types/CommentText.hs @@ -2,23 +2,19 @@ module Level05.Types.CommentText ( CommentText , mkCommentText , getCommentText - , encodeCommentText ) where -import Waargonaut.Encode (Encoder) -import qualified Waargonaut.Encode as E +import Level05.Types.Error (Error (EmptyCommentText), nonEmptyText) -import Level05.Types.Error (Error (EmptyCommentText), - nonEmptyText) +import Data.Aeson (ToJSON (..)) -import Data.Functor.Contravariant ((>$<)) -import Data.Text (Text) +import Data.Text (Text) newtype CommentText = CommentText Text deriving (Show) -encodeCommentText :: Applicative f => Encoder f CommentText -encodeCommentText = getCommentText >$< E.text +instance ToJSON CommentText where + toJSON (CommentText t) = toJSON t mkCommentText :: Text diff --git a/src/Level05/Types/Topic.hs b/src/Level05/Types/Topic.hs index 05a78ca0..d4a47fb4 100644 --- a/src/Level05/Types/Topic.hs +++ b/src/Level05/Types/Topic.hs @@ -2,22 +2,19 @@ module Level05.Types.Topic (Topic , mkTopic , getTopic - , encodeTopic ) where -import Waargonaut.Encode (Encoder) -import qualified Waargonaut.Encode as E +import Level05.Types.Error (Error (EmptyTopic), nonEmptyText) -import Level05.Types.Error (Error (EmptyTopic), nonEmptyText) +import Data.Aeson (ToJSON (..)) -import Data.Functor.Contravariant ((>$<)) -import Data.Text (Text) +import Data.Text (Text) newtype Topic = Topic Text deriving Show -encodeTopic :: Applicative f => Encoder f Topic -encodeTopic = getTopic >$< E.text +instance ToJSON Topic where + toJSON (Topic t) = toJSON t mkTopic :: Text diff --git a/src/Level06/Conf/File.hs b/src/Level06/Conf/File.hs index 2284976f..af11d27f 100644 --- a/src/Level06/Conf/File.hs +++ b/src/Level06/Conf/File.hs @@ -12,10 +12,6 @@ import Control.Exception (try) import qualified Data.Attoparsec.ByteString as AB -import Waargonaut (Json) -import qualified Waargonaut.Decode as D -import Waargonaut.Decode.Error (DecodeError (ParseFailed)) - import Level06.AppM (AppM (runAppM)) import Level06.Types (ConfigError (BadConfFile), PartialConf (PartialConf)) @@ -23,7 +19,7 @@ import Level06.Types (ConfigError (BadConfFile), -- >>> :set -XOverloadedStrings -- | The configuration file is in the JSON format, so we need to write a --- 'waargonaut' 'Decoder' to go from JSON to our 'PartialConf'. +-- 'aeson' 'FromJSON' to go from JSON to our 'PartialConf'. -- -- Update these tests when you've completed this function. -- diff --git a/src/Level06/Core.hs b/src/Level06/Core.hs index 9f2efdbe..795e4f25 100644 --- a/src/Level06/Core.hs +++ b/src/Level06/Core.hs @@ -17,12 +17,12 @@ import Network.Wai (Application, Request, strictRequestBody) import Network.Wai.Handler.Warp (run) +import Data.Aeson (ToJSON (..), encode) +import qualified Data.ByteString.Lazy as LBS import Network.HTTP.Types (Status, hContentType, status200, status400, status404, status500) -import qualified Data.ByteString.Lazy as LBS - import Data.Bifunctor (first) import Data.Either (either) import Data.Monoid ((<>)) @@ -33,18 +33,14 @@ import Data.Text.Lazy.Encoding (encodeUtf8) import Database.SQLite.SimpleErrors.Types (SQLiteResponse) -import Waargonaut.Encode (Encoder') -import qualified Waargonaut.Encode as E - -import Level06.AppM (App, AppM (..), - liftEither, runApp) +import Level06.AppM (App, AppM (..), liftEither, + runApp) import qualified Level06.Conf as Conf import qualified Level06.DB as DB import Level06.Types (Conf, ConfigError, ContentType (..), Error (..), RqType (AddRq, ListRq, ViewRq), - encodeComment, encodeTopic, mkCommentText, mkTopic, renderContentType) @@ -112,12 +108,11 @@ resp500 = mkResponse status500 resp200Json - :: Encoder' a - -> a + :: ToJSON a + => a -> Response -resp200Json e = - resp200 JSON . encodeUtf8 . - E.simplePureEncodeTextNoSpaces e +resp200Json = + resp200 JSON . encode -- | Now that we have our configuration, pass it where it needs to go. app @@ -137,8 +132,8 @@ handleRequest handleRequest db rqType = case rqType of AddRq t c -> resp200 PlainText "Success" <$ DB.addCommentToTopic db t c - ViewRq t -> resp200Json (E.list encodeComment) <$> DB.getComments db t - ListRq -> resp200Json (E.list encodeTopic) <$> DB.getTopics db + ViewRq t -> resp200Json <$> DB.getComments db t + ListRq -> resp200Json <$> DB.getTopics db mkRequest :: Request diff --git a/src/Level06/Types.hs b/src/Level06/Types.hs index 413329b5..0bd59bb3 100644 --- a/src/Level06/Types.hs +++ b/src/Level06/Types.hs @@ -20,25 +20,24 @@ module Level06.Types , CommentText , mkTopic , getTopic - , encodeTopic , mkCommentText , getCommentText - , encodeComment , renderContentType , confPortToWai , fromDBComment ) where -import GHC.Word (Word16) - +import Data.Aeson (FromJSON (..), ToJSON (..), + object, (.=)) import Data.ByteString (ByteString) import Data.Text (Text, pack) +import GHC.Word (Word16) import System.IO.Error (IOError) -import Data.Semigroup (Last (..), Semigroup ((<>))) +import Data.Semigroup (Last (..), + Semigroup ((<>))) -import Data.Functor.Contravariant ((>$<)) import Data.List (stripPrefix) import Data.Maybe (fromMaybe) import Data.Time (UTCTime) @@ -46,30 +45,21 @@ import qualified Data.Time.Format as TF import System.Locale (defaultTimeLocale) -import Waargonaut.Decode (Decoder) -import qualified Waargonaut.Decode as D -import Waargonaut.Decode.Error (DecodeError) - -import Waargonaut.Encode (Encoder) -import qualified Waargonaut.Encode as E - import Database.SQLite.SimpleErrors.Types (SQLiteResponse) import Level06.DB.Types (DBComment (..)) import Level06.Types.CommentText (CommentText, - encodeCommentText, getCommentText, mkCommentText) import Level06.Types.Error (Error (..)) -import Level06.Types.Topic (Topic, encodeTopic, - getTopic, mkTopic) +import Level06.Types.Topic (Topic, getTopic, mkTopic) newtype CommentId = CommentId Int deriving Show -encodeCommentId :: Applicative f => Encoder f CommentId -encodeCommentId = (\(CommentId i) -> i) >$< E.int +instance ToJSON CommentId where + toJSON (CommentId i) = toJSON i data Comment = Comment { commentId :: CommentId @@ -79,18 +69,13 @@ data Comment = Comment } deriving (Show) -encodeISO8601DateTime :: Applicative f => Encoder f UTCTime -encodeISO8601DateTime = E.encodeA $ E.runEncoder E.text . pack . TF.formatTime tl fmt - where - fmt = TF.iso8601DateFormat (Just "%H:%M:%S") - tl = TF.defaultTimeLocale { TF.knownTimeZones = [] } - -encodeComment :: Applicative f => Encoder f Comment -encodeComment = E.mapLikeObj $ \c -> - E.atKey' "id" encodeCommentId (commentId c) . - E.atKey' "topic" encodeTopic (commentTopic c) . - E.atKey' "text" encodeCommentText (commentText c) . - E.atKey' "time" encodeISO8601DateTime (commentTime c) +instance ToJSON Comment where + toJSON c = object + [ "id" .= (commentId c) + , "topic" .= (commentTopic c) + , "text" .= (commentText c) + , "time" .= (commentTime c) + ] -- 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 @@ -173,7 +158,7 @@ confPortToWai = -- Similar to when we were considering our application types. We can add to this sum type -- as we build our application and the compiler can help us out. data ConfigError - = BadConfFile DecodeError + = BadConfFile String deriving Show -- Our application will be able to load configuration from both a file and @@ -217,11 +202,10 @@ instance Semigroup PartialConf where -- been completed for you, feel free to have a look through the 'CommandLine' -- module and see how it works. -- --- For reading the configuration from the file, we're going to use the Waargonaut --- library to handle the parsing and decoding for us. In order to do this, we --- have to tell waargonaut how to go about converting the JSON into our PartialConf --- data structure. -partialConfDecoder :: Monad f => Decoder f PartialConf -partialConfDecoder = error "PartialConf Decoder not implemented" +-- For reading the configuration from the file, we're going to use the Aeson library to handle the +-- parsing and decoding for us. For this to work we'll need to complete a 'FromJSON' instance to +-- tell Aeson how to create our 'PartialConf' type from the JSON input. +instance FromJSON PartialConf where + parseJSON = error "PartialConf FromJSON instance not implemented." -- Go to 'src/Level06/Conf/File.hs' next diff --git a/src/Level06/Types/CommentText.hs b/src/Level06/Types/CommentText.hs index ad5bab73..ace938af 100644 --- a/src/Level06/Types/CommentText.hs +++ b/src/Level06/Types/CommentText.hs @@ -2,23 +2,19 @@ module Level06.Types.CommentText ( CommentText , mkCommentText , getCommentText - , encodeCommentText ) where -import Waargonaut.Encode (Encoder) -import qualified Waargonaut.Encode as E +import Data.Aeson (ToJSON (..)) -import Level06.Types.Error (Error (EmptyCommentText), - nonEmptyText) +import Level06.Types.Error (Error (EmptyCommentText), nonEmptyText) -import Data.Functor.Contravariant ((>$<)) -import Data.Text (Text) +import Data.Text (Text) newtype CommentText = CommentText Text deriving (Show) -encodeCommentText :: Applicative f => Encoder f CommentText -encodeCommentText = getCommentText >$< E.text +instance ToJSON CommentText where + toJSON (CommentText t) = toJSON t mkCommentText :: Text diff --git a/src/Level06/Types/Topic.hs b/src/Level06/Types/Topic.hs index 31fd26cf..0a67df59 100644 --- a/src/Level06/Types/Topic.hs +++ b/src/Level06/Types/Topic.hs @@ -2,22 +2,19 @@ module Level06.Types.Topic ( Topic , mkTopic , getTopic - , encodeTopic ) where -import Waargonaut.Encode (Encoder) -import qualified Waargonaut.Encode as E +import Data.Aeson (ToJSON (..)) -import Level06.Types.Error (Error (EmptyTopic), nonEmptyText) +import Level06.Types.Error (Error (EmptyTopic), nonEmptyText) -import Data.Functor.Contravariant ((>$<)) -import Data.Text (Text) +import Data.Text (Text) newtype Topic = Topic Text deriving Show -encodeTopic :: Applicative f => Encoder f Topic -encodeTopic = getTopic >$< E.text +instance ToJSON Topic where + toJSON (Topic t) = toJSON t mkTopic :: Text diff --git a/src/Level07/Conf/File.hs b/src/Level07/Conf/File.hs index cf043920..f89c9f3e 100644 --- a/src/Level07/Conf/File.hs +++ b/src/Level07/Conf/File.hs @@ -1,18 +1,17 @@ module Level07.Conf.File where -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as LBS +import Data.Aeson (eitherDecode) -import Data.Text (pack) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy.Char8 as LBS -import Data.Bifunctor (first) +import Data.Text (pack) -import Waargonaut.Attoparsec (pureDecodeAttoparsecByteString) +import Data.Bifunctor (first) -import Control.Exception (try) +import Control.Exception (try) -import Level07.Types (ConfigError (..), PartialConf, - partialConfDecoder) +import Level07.Types (ConfigError (..), PartialConf) -- Doctest setup section -- $setup @@ -38,6 +37,4 @@ parseJSONConfigFile :: FilePath -> IO ( Either ConfigError PartialConf ) parseJSONConfigFile fp = - (first BadConfFile . runDecode =<<) <$> readConfFile fp - where - runDecode = pureDecodeAttoparsecByteString partialConfDecoder + (first BadConfFile . eitherDecode =<<) <$> readConfFile fp diff --git a/src/Level07/Core.hs b/src/Level07/Core.hs index 9e6a5d49..954019a4 100644 --- a/src/Level07/Core.hs +++ b/src/Level07/Core.hs @@ -33,8 +33,6 @@ import Database.SQLite.SimpleErrors.Types (SQLiteResponse) import System.IO (stderr) -import qualified Waargonaut.Encode as E - import qualified Level07.Conf as Conf import qualified Level07.DB as DB @@ -43,7 +41,6 @@ import Level07.Types (Conf, ConfigError, ContentType (PlainText), Error (..), RqType (..), confPortToWai, - encodeComment, encodeTopic, mkCommentText, mkTopic) import Level07.AppM (App, Env (..), liftEither, @@ -102,8 +99,8 @@ handleRequest -> App Response handleRequest rqType = case rqType of AddRq t c -> Res.resp200 PlainText "Success" <$ DB.addCommentToTopic t c - ViewRq t -> Res.resp200Json (E.list encodeComment) <$> DB.getComments t - ListRq -> Res.resp200Json (E.list encodeTopic) <$> DB.getTopics + ViewRq t -> Res.resp200Json <$> DB.getComments t + ListRq -> Res.resp200Json <$> DB.getTopics mkRequest :: Request diff --git a/src/Level07/Responses.hs b/src/Level07/Responses.hs index 2eca3a22..5bca2b5e 100644 --- a/src/Level07/Responses.hs +++ b/src/Level07/Responses.hs @@ -1,5 +1,7 @@ module Level07.Responses where +import Data.Aeson (ToJSON (..), encode) + import Network.Wai (Response, responseLBS) import Network.HTTP.Types (Status, hContentType, status200, @@ -9,9 +11,6 @@ import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Text.Lazy.Encoding (encodeUtf8) -import Waargonaut.Encode (Encoder') -import qualified Waargonaut.Encode as E - import Level07.Types (ContentType (JSON), renderContentType) @@ -53,9 +52,8 @@ resp500 = mkResponse status500 resp200Json - :: Encoder' a - -> a + :: ToJSON a + => a -> Response -resp200Json e = - resp200 JSON . encodeUtf8 . - E.simplePureEncodeTextNoSpaces e +resp200Json = + resp200 JSON . encode diff --git a/src/Level07/Types.hs b/src/Level07/Types.hs index dfad32d8..d8be6d98 100644 --- a/src/Level07/Types.hs +++ b/src/Level07/Types.hs @@ -12,7 +12,6 @@ module Level07.Types , Comment (..) , Topic , CommentText - , partialConfDecoder , mkTopic , getTopic , mkCommentText @@ -20,30 +19,26 @@ module Level07.Types , renderContentType , fromDBComment , confPortToWai - , encodeComment - , encodeTopic ) where import System.IO.Error (IOError) -import GHC.Word (Word16) - +import Data.Aeson (FromJSON (..), ToJSON (..), + Value (..), object, (.:), + (.=)) import Data.ByteString (ByteString) -import Data.Text (pack) +import Data.Either (fromRight) +import Data.Scientific (toBoundedInteger) +import Data.Text (pack, unpack) +import GHC.Word (Word16) import Data.Functor.Contravariant ((>$<)) -import Data.Semigroup (Last (Last), Semigroup ((<>))) +import Data.Semigroup (Last (Last), + Semigroup ((<>))) import Data.Time (UTCTime) import qualified Data.Time.Format as TF -import Waargonaut.Decode (CursorHistory, Decoder) -import qualified Waargonaut.Decode as D -import Waargonaut.Decode.Error (DecodeError) - -import Waargonaut.Encode (Encoder) -import qualified Waargonaut.Encode as E - import Database.SQLite.Simple (Connection) import Database.SQLite.SimpleErrors.Types (SQLiteResponse) @@ -52,18 +47,16 @@ import Level07.DB.Types (DBComment (dbCommentComment import Level07.Types.Error (Error (DBError, EmptyCommentText, EmptyTopic, UnknownRoute)) import Level07.Types.CommentText (CommentText, - encodeCommentText, getCommentText, mkCommentText) -import Level07.Types.Topic (Topic, encodeTopic, - getTopic, mkTopic) +import Level07.Types.Topic (Topic, getTopic, mkTopic) newtype CommentId = CommentId Int deriving (Show) -encodeCommentId :: Applicative f => Encoder f CommentId -encodeCommentId = (\(CommentId i) -> i) >$< E.int +instance ToJSON CommentId where + toJSON (CommentId i) = toJSON i data Comment = Comment { commentId :: CommentId @@ -73,18 +66,13 @@ data Comment = Comment } deriving Show -encodeISO8601DateTime :: Applicative f => Encoder f UTCTime -encodeISO8601DateTime = pack . TF.formatTime tl fmt >$< E.text - where - fmt = TF.iso8601DateFormat (Just "%H:%M:%S") - tl = TF.defaultTimeLocale { TF.knownTimeZones = [] } - -encodeComment :: Applicative f => Encoder f Comment -encodeComment = E.mapLikeObj $ \c -> - E.atKey' "id" encodeCommentId (commentId c) . - E.atKey' "topic" encodeTopic (commentTopic c) . - E.atKey' "text" encodeCommentText (commentText c) . - E.atKey' "time" encodeISO8601DateTime (commentTime c) +instance ToJSON Comment where + toJSON c = object + [ "id" .= (commentId c) + , "topic" .= (commentTopic c) + , "text" .= (commentText c) + , "time" .= (commentTime c) + ] -- 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 @@ -128,10 +116,18 @@ newtype Port = Port { getPort :: Word16 } deriving (Eq, Show) +instance FromJSON Port where + parseJSON (Number n) = maybe (fail "Invalid Port value in config") (pure . Port) $ toBoundedInteger n + parseJSON _ = fail "Invalid value for Port in config" + newtype DBFilePath = DBFilePath { getDBFilePath :: FilePath } deriving (Eq, Show) +instance FromJSON DBFilePath where + parseJSON (String s) = pure $ DBFilePath $ unpack s + parseJSON _ = fail "Invalid value for DBFilePath in config (expects string)" + -- The ``Conf`` type will need: -- - A customisable port number: ``Port`` -- - A filepath for our SQLite database: ``DBFilePath`` @@ -154,7 +150,8 @@ confPortToWai = -- Similar to when we were considering our application types, leave this empty -- for now and add to it as you go. data ConfigError - = BadConfFile (DecodeError, CursorHistory) + -- = BadConfFile (DecodeError, CursorHistory) + = BadConfFile String | MissingPort | MissingDBFilePath | JSONDecodeError String @@ -206,12 +203,11 @@ instance Semigroup PartialConf where -- library to handle the parsing and decoding for us. In order to do this, we -- have to tell waargonaut how to go about converting the JSON into our PartialConf -- data structure. -partialConfDecoder :: Monad f => Decoder f PartialConf -partialConfDecoder = PartialConf - <$> lastAt "port" D.integral Port - <*> lastAt "dbFilePath" D.string DBFilePath - where - lastAt k d c = fmap (Last . c) <$> D.atKeyOptional k d +instance FromJSON PartialConf where + parseJSON (Object o) = PartialConf + <$> (o .: "port") + <*> (o .: "dbFilePath") + parseJSON _ = fail "Invalid input for PartialConf in config (expects object)" -- 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 diff --git a/src/Level07/Types/CommentText.hs b/src/Level07/Types/CommentText.hs index 88429093..29e62273 100644 --- a/src/Level07/Types/CommentText.hs +++ b/src/Level07/Types/CommentText.hs @@ -2,23 +2,19 @@ module Level07.Types.CommentText ( CommentText , mkCommentText , getCommentText - , encodeCommentText ) where -import Waargonaut.Encode (Encoder) -import qualified Waargonaut.Encode as E +import Data.Aeson (ToJSON (..)) -import Data.Functor.Contravariant ((>$<)) -import Data.Text (Text) +import Level07.Types.Error (Error (EmptyCommentText), nonEmptyText) -import Level07.Types.Error (Error (EmptyCommentText), - nonEmptyText) +import Data.Text (Text) newtype CommentText = CommentText Text deriving (Show) -encodeCommentText :: Applicative f => Encoder f CommentText -encodeCommentText = getCommentText >$< E.text +instance ToJSON CommentText where + toJSON (CommentText t) = toJSON t mkCommentText :: Text diff --git a/src/Level07/Types/Topic.hs b/src/Level07/Types/Topic.hs index 0a277145..9da3a5f3 100644 --- a/src/Level07/Types/Topic.hs +++ b/src/Level07/Types/Topic.hs @@ -2,22 +2,19 @@ module Level07.Types.Topic ( Topic , mkTopic , getTopic - , encodeTopic ) where -import Waargonaut.Encode (Encoder) -import qualified Waargonaut.Encode as E +import Data.Aeson (ToJSON (..)) -import Data.Functor.Contravariant ((>$<)) -import Data.Text (Text) +import Data.Text (Text) -import Level07.Types.Error (Error (EmptyTopic), nonEmptyText) +import Level07.Types.Error (Error (EmptyTopic), nonEmptyText) newtype Topic = Topic Text deriving (Show) -encodeTopic :: Applicative f => Encoder f Topic -encodeTopic = getTopic >$< E.text +instance ToJSON Topic where + toJSON (Topic t) = toJSON t mkTopic :: Text From d02d07a480693a7b7b165aaa8afe97bc85a495f3 Mon Sep 17 00:00:00 2001 From: Sean Chalmers Date: Mon, 20 Nov 2023 13:29:07 +0000 Subject: [PATCH 2/2] Remove commented code in flake.nix and redundant tool --- flake.nix | 6 ------ 1 file changed, 6 deletions(-) diff --git a/flake.nix b/flake.nix index a37c1f30..f0e15718 100644 --- a/flake.nix +++ b/flake.nix @@ -20,12 +20,8 @@ root = ./.; overrides = final: prev: with nixpkgs.haskell.lib; { - # hw-json-simd = dontCheck (unmarkBroken prev.hw-json-simd); - # hw-json-standard-cursor = doJailbreak prev.hw-json-standard-cursor; - # natural = dontCheck (unmarkBroken prev.natural); sqlite-simple-errors = unmarkBroken (doJailbreak prev.sqlite-simple-errors); - # waargonaut = dontCheck (doJailbreak prev.waargonaut); }; }; in @@ -37,8 +33,6 @@ nixpkgs.cabal-install nixpkgs.ghcid nixpkgs.sqlite - - nixpkgs.stylish-haskell ]; }); });