bd4175d1-f249-4c7e-b1a7-608a150c31cb

Committed 13 Jun 2025 05:02PM UTC coverage: 32.165%. Remained the same

Build # bd4175d1-f249-4c7e-b1a7-608a150c31cb

Build Type

push

circleci

Committed by

web-flow

Commit Message

Refactored Graph functions into new Models.Graph module (#1566)

Run Details

21 of 140 branches covered (15.0%)

Branch coverage included in aggregate %.

0 of 50 new or added lines in 2 files covered. (0.0%)

5 existing lines in 1 file now uncovered.

640 of 1915 relevant lines covered (33.42%)

26.37 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

10.34

/app/Controllers/Graph.hs

module Controllers.Graph (graphResponse, index, getGraphJSON, graphImageResponse, saveGraphJSON) where

import Control.Monad.IO.Class (liftIO)
import Data.Aeson (decode, object, (.=))
import Data.Maybe (fromMaybe)
import Happstack.Server (Response, ServerPart, look, lookBS, lookText', ok, toResponse)
import MasterTemplate (header, masterTemplate)
import Scripts (graphScripts)
import Text.Blaze ((!))
import qualified Text.Blaze.Html5 as H
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 Export.GetImages (getActiveGraphImage)
import Models.Graph (getGraph, insertGraph)
import Response.Image (returnImageData)
import Util.Happstack (createJSONResponse)

graphResponse :: ServerPart Response
graphResponse =
   ok $ toResponse $
    masterTemplate "Courseography - Graph"
                []
                (do
                    header "graph"
                    H.div ! A.id "container" $ ""
                )
                graphScripts


index :: ServerPart Response
index = liftIO $ runDb $ do
    graphsList :: [Entity Graph] <- selectList [GraphDynamic ==. False] [Asc GraphTitle]
    return $ createJSONResponse graphsList :: SqlPersistM Response


-- | Looks up a graph using its title then gets the Shape, Text and Path elements
-- for rendering graph (returned as JSON).
getGraphJSON :: ServerPart Response
getGraphJSON = do
    graphName <- lookText' "graphName"
    response <- liftIO $ getGraph graphName
    return $ createJSONResponse $ fromMaybe (object ["texts" .= ([] :: [Text]),
                                                    "shapes" .= ([] :: [Text]),
                                                    "paths" .= ([] :: [Text])]) response


-- | Returns an image of the graph requested by the user, given graphInfo stored in local storage.
graphImageResponse :: ServerPart Response
graphImageResponse = do
    graphInfo <- look "JsonLocalStorageObj"
    (svgFilename, imageFilename) <- liftIO $ getActiveGraphImage graphInfo
    liftIO $ returnImageData svgFilename imageFilename

-- | Inserts SVG graph data into Texts, Shapes, and Paths tables
saveGraphJSON :: ServerPart Response
saveGraphJSON = do
    jsonStr <- lookBS "jsonData"
    nameStr <- lookText' "nameData"
    let jsonObj = decode jsonStr :: Maybe SvgJSON
    case jsonObj of
        Nothing -> return $ toResponse ("Error" :: String)
        Just svg -> do
            _ <- liftIO $ runDb $ insertGraph nameStr svg
            return $ toResponse ("Success" :: String)

1	module Controllers.Graph (graphResponse, index, getGraphJSON, graphImageResponse, saveGraphJSON) where
2
3	import Control.Monad.IO.Class (liftIO)
4	import Data.Aeson (decode, object, (.=))
5	import Data.Maybe (fromMaybe)
6	import Happstack.Server (Response, ServerPart, look, lookBS, lookText', ok, toResponse)
7	import MasterTemplate (header, masterTemplate)
8	import Scripts (graphScripts)
9	import Text.Blaze ((!))
10	import qualified Text.Blaze.Html5 as H
11	import qualified Text.Blaze.Html5.Attributes as A
12
13	import Config (runDb)
14	import Database.Persist.Sqlite (Entity, SelectOpt (Asc), SqlPersistM, selectList, (==.))
15	import Database.Tables as Tables (EntityField (GraphDynamic, GraphTitle), Graph, SvgJSON, Text)
16	import Export.GetImages (getActiveGraphImage)
17	import Models.Graph (getGraph, insertGraph)
18	import Response.Image (returnImageData)
19	import Util.Happstack (createJSONResponse)
20
21	graphResponse :: ServerPart Response
22	graphResponse =
23	ok $ toResponse $	×
24	masterTemplate "Courseography - Graph"	×
25	[]	×
26	(do	×
27	header "graph"	×
28	H.div ! A.id "container" $ ""	×
29	)
30	graphScripts	×
31
32
33	index :: ServerPart Response
34	index = liftIO $ runDb $ do	3✔
35	graphsList :: [Entity Graph] <- selectList [GraphDynamic ==. False] [Asc GraphTitle]	1✔
36	return $ createJSONResponse graphsList :: SqlPersistM Response	3✔
37
38
39	-- \| Looks up a graph using its title then gets the Shape, Text and Path elements
40	-- for rendering graph (returned as JSON).
41	getGraphJSON :: ServerPart Response
42	getGraphJSON = do	×
43	graphName <- lookText' "graphName"	×
44	response <- liftIO $ getGraph graphName	×
45	return $ createJSONResponse $ fromMaybe (object ["texts" .= ([] :: [Text]),	×
46	"shapes" .= ([] :: [Text]),	×
47	"paths" .= ([] :: [Text])]) response	×
48
49
50	-- \| Returns an image of the graph requested by the user, given graphInfo stored in local storage.
51	graphImageResponse :: ServerPart Response
52	graphImageResponse = do	×
53	graphInfo <- look "JsonLocalStorageObj"	×
54	(svgFilename, imageFilename) <- liftIO $ getActiveGraphImage graphInfo	×
55	liftIO $ returnImageData svgFilename imageFilename	×
56
57	-- \| Inserts SVG graph data into Texts, Shapes, and Paths tables
58	saveGraphJSON :: ServerPart Response
NEW 59	saveGraphJSON = do	×
NEW 60	jsonStr <- lookBS "jsonData"	×
NEW 61	nameStr <- lookText' "nameData"	×
NEW 62	let jsonObj = decode jsonStr :: Maybe SvgJSON	×
NEW 63	case jsonObj of	×
NEW 64	Nothing -> return $ toResponse ("Error" :: String)	×
NEW 65	Just svg -> do	×
NEW 66	_ <- liftIO $ runDb $ insertGraph nameStr svg	×
NEW 67	return $ toResponse ("Success" :: String)	×

Courseography / courseography / bd4175d1-f249-4c7e-b1a7-608a150c31cb

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous