b17a4f5a-53dd-4f11-807c-7a64c9ccb0cb

Committed 06 Mar 2026 07:44AM UTC coverage: 56.605% (+0.2%) from 56.41%

Build # b17a4f5a-53dd-4f11-807c-7a64c9ccb0cb

Build Type

Pull #1667

circleci

Committed by

a1-su

Commit Message

Refactor Controllers/Timetable.hs to use temporary files

Pull Request Pull Request #1667: Refactor graphImageResponse to use Temporary Files

Coverage Stats

501 of 962 branches covered (52.08%)

Branch coverage included in aggregate %.

0 of 22 new or added lines in 4 files covered. (0.0%)

20 existing lines in 1 file now uncovered.

2280 of 3951 relevant lines covered (57.71%)

163.02 hits per line

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

47.06

/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 Export.ImageConversion
import Happstack.Server (Response, ServerPart, look, lookBS, lookText', ok, toResponse)
import MasterTemplate (masterTemplate)
import Scripts (graphScripts)
import System.IO (hClose)
import System.IO.Temp (withSystemTempFile)
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 (writeActiveGraphImage)
import Models.Graph (getGraph, insertGraph)
import Util.Happstack (createJSONResponse)
import Util.Helpers (readImageData)

graphResponse :: ServerPart Response
graphResponse =
   ok $ toResponse $
    masterTemplate "Courseography - Graph"
                []
                (do
                    H.div ! A.id "navbar" $ ""
                    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"
    liftIO $ withSystemTempFile "graph.svg" $ \svgPath svgHandle -> do
        withSystemTempFile "graph.png" $ \pngPath pngHandle -> do
            hClose pngHandle
            writeActiveGraphImage graphInfo svgHandle
            hClose svgHandle
            createImageFile svgPath pngPath
            readImageData pngPath

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

Courseography / courseography / b17a4f5a-53dd-4f11-807c-7a64c9ccb0cb

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