diff --git a/CHANGELOG.md b/CHANGELOG.md index f31197266..d3076afd7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -33,6 +33,7 @@ - Refactor graph helper functions from `app/Svg/Database.hs` to `app/Models/Graph.hs` - Refactor functions for performing matrix operations from `app/Svg/Parser.hs` to `app/Util/Matrix.hs` - Updated documentation in `app/Util/Blaze.hs` +- Removed `SvgJSON` data type in favour of `([Text], [Shape], [Path])` ## [0.7.2] - 2025-12-10 diff --git a/app/Controllers/Graph.hs b/app/Controllers/Graph.hs index 51b4b31f5..d40dd754e 100644 --- a/app/Controllers/Graph.hs +++ b/app/Controllers/Graph.hs @@ -1,7 +1,7 @@ module Controllers.Graph (graphResponse, index, getGraphJSON, graphImageResponse, saveGraphJSON) where import Control.Monad.IO.Class (liftIO) -import Data.Aeson (decode, object, (.=)) +import Data.Aeson (object, (.=)) import Data.Maybe (fromMaybe) import Export.ImageConversion (withImageFile) import Happstack.Server (Response, ServerPart, lookBS, lookText', ok, toResponse) @@ -15,9 +15,9 @@ import qualified Text.Blaze.Html5.Attributes as A import Config (runDb) import Database.Persist.Sqlite (Entity, SelectOpt (Asc), SqlPersistM, selectList, (==.)) -import Database.Tables as Tables (EntityField (GraphDynamic, GraphTitle), Graph, SvgJSON, Text) +import Database.Tables as Tables (EntityField(GraphTitle, GraphDynamic), Text, Graph) import Export.GetImages (writeActiveGraphImage) -import Models.Graph (getGraph, insertGraph) +import Models.Graph (getGraph, insertGraph, parseGraphComponentsJSON) import Util.Happstack (createJSONResponse) import Util.Helpers (readImageData) @@ -64,9 +64,9 @@ saveGraphJSON :: ServerPart Response saveGraphJSON = do jsonStr <- lookBS "jsonData" nameStr <- lookText' "nameData" - let jsonObj = decode jsonStr :: Maybe SvgJSON + let jsonObj = parseGraphComponentsJSON jsonStr case jsonObj of Nothing -> return $ toResponse ("Error" :: String) - Just svg -> do - _ <- liftIO $ runDb $ insertGraph nameStr svg + Just components -> do + _ <- liftIO $ runDb $ insertGraph nameStr components return $ toResponse ("Success" :: String) diff --git a/app/Database/Tables.hs b/app/Database/Tables.hs index fe5c631e6..6a3117adf 100644 --- a/app/Database/Tables.hs +++ b/app/Database/Tables.hs @@ -19,8 +19,8 @@ straightforward. module Database.Tables where -import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), genericToJSON, withObject, (.!=), (.:), - (.:?)) +import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), genericToJSON, withObject, + (.!=), (.:), (.:?)) import Data.Aeson.Types (Options (..), Parser, Value (Object), defaultOptions) import Data.Char (toLower) import qualified Data.Text as T @@ -161,13 +161,6 @@ SchemaVersion -- ** TODO: Remove these extra types and class instances --- | JSON SVG data -data SvgJSON = - SvgJSON { texts :: [Text], - shapes :: [Shape], - paths :: [Path] - } deriving (Show, Generic) - data Time' = Time' { weekDay' :: Double, startHour' :: Double, @@ -211,10 +204,6 @@ instance ToJSON Time instance ToJSON MeetTime' instance ToJSON Building --- instance FromJSON required so that tables can be parsed into JSON, --- not necessary otherwise. -instance FromJSON SvgJSON - instance ToJSON Meeting where toJSON = genericToJSON defaultOptions { fieldLabelModifier = diff --git a/app/Models/Graph.hs b/app/Models/Graph.hs index 29e4dcf3d..0574d6f6c 100644 --- a/app/Models/Graph.hs +++ b/app/Models/Graph.hs @@ -1,14 +1,17 @@ module Models.Graph - (getGraph, insertGraph, insertElements, deleteExistingGraph) where + (getGraph, insertGraph, insertElements, deleteExistingGraph, parseGraphComponentsJSON) where import Config (runDb) -import Data.Aeson (Value, object, toJSON) +import Data.Aeson (Value, decode, object, toJSON, (.:)) +import Data.Aeson.Types (parseMaybe) import qualified Data.Text as T (Text) +import qualified Data.ByteString.Lazy as L import Database.DataType (ShapeType (BoolNode, Hybrid, Node)) import Database.Persist.Sqlite (Entity, PersistEntity, PersistValue (PersistInt64), SqlPersistM, deleteWhere, entityKey, entityVal, insert, insert_, insertMany_, keyToValues, selectFirst, selectList, (<-.), (==.)) -import Database.Tables hiding (paths, shapes, texts) +import Database.Tables (EntityField(GraphId, ShapeType_, GraphTitle, TextGraph, ShapeGraph, PathGraph), + Key, Path(pathGraph), Shape(shapeGraph), Text(textGraph), Graph(graphWidth, graphHeight, Graph)) import Svg.Builder (buildEllipses, buildPath, buildRect) import Util.Helpers @@ -55,10 +58,10 @@ getGraph graphName = runDb $ do -- | Insert a new graph into the database, given its SVG JSON. -- | Return Nothing. -insertGraph :: T.Text -- ^ The title of the graph being inserted. - -> SvgJSON -- ^ The SVG JSON data of the inserted graph (texts, shapes, paths). - -> SqlPersistM () -- ^ Return Nothing. -insertGraph nameStr_ (SvgJSON texts shapes paths) = do +insertGraph :: T.Text -- ^ The title of the graph being inserted. + -> ([Text], [Shape], [Path]) -- ^ The parsed JSON data of the inserted graph. + -> SqlPersistM () -- ^ Return Nothing. +insertGraph nameStr_ (texts, shapes, paths) = do gId <- insert $ Graph nameStr_ 256 256 False insertMany_ $ map (\text -> text {textGraph = gId}) texts insertMany_ $ map (\shape -> shape {shapeGraph = gId}) shapes @@ -88,3 +91,14 @@ deleteGraph gId = do deleteWhere [ShapeGraph ==. gId] deleteWhere [PathGraph ==. gId] deleteWhere [GraphId ==. gId] + +-- | Parse the JSON representation of a graph into its texts, shapes, and paths components. +parseGraphComponentsJSON :: L.ByteString -> Maybe ([Text], [Shape], [Path]) +parseGraphComponentsJSON jsonStr = do + obj <- decode jsonStr + parseMaybe (\o -> do + texts <- o .: "texts" + shapes <- o .: "shapes" + paths <- o .: "paths" + return (texts, shapes, paths) + ) obj diff --git a/app/Svg/Builder.hs b/app/Svg/Builder.hs index cd5a51f2f..6d8f8b6bf 100644 --- a/app/Svg/Builder.hs +++ b/app/Svg/Builder.hs @@ -21,7 +21,10 @@ import Data.Char (toLower) import Data.List (find) import qualified Data.Text as T import Database.DataType -import Database.Tables hiding (shapes, texts) +import Database.Tables (Matrix, Point, + Path(pathTarget, pathIsRegion, pathPoints, pathTransform, pathId_, pathSource), + Shape(shapeText, shapeWidth, shapeHeight, shapePos, shapeTransform, shapeType_, shapeId_), + Text(textPos, textText, textTransform)) import Util.Matrix (matrixPointMultiply) import TextShow (showt) import Util.Helpers diff --git a/app/Svg/Generator.hs b/app/Svg/Generator.hs index ffd69c94f..509eb81ce 100644 --- a/app/Svg/Generator.hs +++ b/app/Svg/Generator.hs @@ -21,7 +21,11 @@ import Data.Maybe (fromMaybe) import qualified Data.Text as T import Database.DataType import Database.Persist.Sqlite -import Database.Tables hiding (paths, texts) +import Database.Tables (EntityField(ShapeGraph, GraphTitle, TextGraph, PathGraph, ShapeType_), + Path(pathFill, pathIsRegion, pathSource, pathTarget, pathId_, pathPoints, pathTransform), + Shape(shapeText, shapeFill, shapeType_, shapeId_, shapeTransform, shapeWidth, shapeHeight, shapePos), + Text(textText, textPos, textAlign, textFill, textTransform), + Graph(graphHeight, graphWidth)) import Svg.Builder import System.IO (Handle, hPutStrLn) import Text.Blaze (toMarkup) diff --git a/app/Svg/Parser.hs b/app/Svg/Parser.hs index a9be16f3b..85b60c11e 100644 --- a/app/Svg/Parser.hs +++ b/app/Svg/Parser.hs @@ -25,7 +25,9 @@ import qualified Data.Text as T import Data.Text.IO as T (readFile) import Database.DataType import Database.Persist.Sqlite -import Database.Tables hiding (graphHeight, graphWidth, paths, shapes, texts) +import Database.Tables (Matrix, Point, + Path(pathFill, Path), Shape(shapeType_, shapeWidth, shapePos, Shape, shapeFill), + Text(Text), Graph(Graph), GraphId) import Models.Graph (deleteExistingGraph, insertElements) import qualified Text.HTML.TagSoup as TS hiding (fromAttrib) import Text.HTML.TagSoup (Tag) diff --git a/backend-test/Controllers/GraphControllerTests.hs b/backend-test/Controllers/GraphControllerTests.hs index 9910dfb59..46ef7fda1 100644 --- a/backend-test/Controllers/GraphControllerTests.hs +++ b/backend-test/Controllers/GraphControllerTests.hs @@ -18,9 +18,9 @@ import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.Text as T import Database.Persist.Sqlite (SqlPersistM, insert_, toSqlKey) -import Database.Tables (Graph (..), Path (..), Shape (..), Text (..), SvgJSON (..)) +import Database.Tables (Graph(Graph), Path(..), Shape(..), Text(..)) import Happstack.Server (rsBody) -import Models.Graph (getGraph, insertGraph) +import Models.Graph (getGraph, insertGraph, parseGraphComponentsJSON) import Test.Tasty (TestTree) import Test.Tasty.HUnit (assertEqual, assertFailure, testCase) import TestHelpers (clearDatabase, mockPutRequest, runServerPart, runServerPartWith, withDatabase, mockGetRequest) @@ -187,16 +187,16 @@ runGetGraphJSONTest (label, (texts', shapes', paths')) = let graphName = "Test Graph Name" runDb $ do clearDatabase - insertGraph graphName (SvgJSON texts' shapes' paths') + insertGraph graphName (texts', shapes', paths') response <- runServerPartWith Controllers.Graph.getGraphJSON $ mockGetRequest "/get-json-data" [("graphName", T.unpack graphName)] "" let body = rsBody response - let jsonObj = decode body :: Maybe SvgJSON + let jsonObj = parseGraphComponentsJSON body case jsonObj of - Nothing -> assertFailure ("Maybe SvgJSON returned as Nothing for " ++ label) - Just svg -> do - assertEqual ("Texts differ for " ++ label) texts' (map (\text -> text {textGraph = toSqlKey 1}) (texts svg)) - assertEqual ("Shapes differ for " ++ label) shapes' (map (\shape -> shape {shapeGraph = toSqlKey 1}) (shapes svg)) - assertEqual ("Paths differ for " ++ label) paths' (map (\path -> path {pathGraph = toSqlKey 1}) (paths svg)) + Nothing -> assertFailure ("Maybe ([Text], [Shape], [Path]) returned as Nothing for " ++ label) + Just (parsedTexts, parsedShapes, parsedPaths) -> do + assertEqual ("Texts differ for " ++ label) texts' (map (\text -> text {textGraph = toSqlKey 1}) parsedTexts) + assertEqual ("Shapes differ for " ++ label) shapes' (map (\shape -> shape {shapeGraph = toSqlKey 1}) parsedShapes) + assertEqual ("Paths differ for " ++ label) paths' (map (\path -> path {pathGraph = toSqlKey 1}) parsedPaths) -- | Run all getGraphJSON tests runGetGraphJSONTests :: [TestTree]