Updated generate form to search for programs (#1525)

Author: Jai0212

CHANGELOG.md

@@ -10,6 +10,7 @@
 - Added text warnings and validations for each field in `GenerateForm`
 - Redesigned generate form UI
 - Allow option to log server request accesses to a file
+- Added search by program to create graphs on Generate Page
 
 ### 🐛 Bug fixes
 

app/Controllers/Generate.hs

@@ -7,12 +7,16 @@ import Scripts
 import Text.Blaze ((!))
 import qualified Text.Blaze.Html5 as H
 import qualified Text.Blaze.Html5.Attributes as A
+import Control.Monad()
+import Control.Monad.IO.Class (liftIO)
+import Data.Aeson (decode, object, (.=))
+import Data.List (nub)
+import Data.Maybe (fromJust, isNothing, mapMaybe)
+import qualified Data.Text.Lazy as TL
+import Database.CourseQueries (returnPost, reqsForPost)
 import DynamicGraphs.WriteRunDot (getBody, generateAndSavePrereqResponse)
 import DynamicGraphs.GraphOptions (CourseGraphOptions (..), GraphOptions (..))
-import Data.Maybe (fromJust)
-import Data.Aeson (decode)
-import qualified Data.Text.Lazy as TL
-import Control.Monad.IO.Class (liftIO)
+import Util.Happstack (createJSONResponse)
 
 generateResponse :: ServerPart Response
 generateResponse =
@@ -37,11 +41,28 @@ findAndSavePrereqsResponse = do
     method PUT
     requestBody <- getBody
     let coursesOptions :: CourseGraphOptions = fromJust $ decode requestBody
+    
+    postResults <- liftIO $ mapM (\code -> do
+                        post <- returnPost (TL.toStrict code)
+                        return (TL.toStrict code, post)) 
+                   (programs coursesOptions)
+
+    let invalidPrograms = map fst $ filter (isNothing . snd) postResults
+        validPrograms = mapMaybe snd postResults
+
+    allCourses <- liftIO $ nub <$>
+        if all (== TL.empty) (courses coursesOptions)
+            then return $ map TL.pack (concatMap reqsForPost validPrograms)
+            else return $ courses coursesOptions
+
     let updatedCoursesOptions = coursesOptions 
-            { courses = map TL.toUpper (courses coursesOptions)
+            { courses = map TL.toUpper allCourses
             , graphOptions = (graphOptions coursesOptions) 
                 { taken = map TL.toUpper (taken (graphOptions coursesOptions))
                 , departments = map TL.toUpper (departments (graphOptions coursesOptions))
                 }
             }
-    liftIO $ generateAndSavePrereqResponse updatedCoursesOptions
+
+    if all (== TL.empty) (courses coursesOptions) && not (null invalidPrograms)
+        then return $ createJSONResponse $ object ["error" .= object ["invalidPrograms" .= invalidPrograms]]
+        else liftIO $ generateAndSavePrereqResponse updatedCoursesOptions

app/Database/CourseQueries.hs

@@ -10,6 +10,8 @@ and serve the information back to the client.
 
 module Database.CourseQueries
     (retrievePost,
+     returnPost,
+     reqsForPost,
      returnCourse,
      prereqsForCourse,
      returnMeeting,
@@ -23,9 +25,10 @@ module Database.CourseQueries
 import Config (runDb)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Aeson (object, toJSON, Value)
+import Data.Char (isAlphaNum, isPunctuation, isAlpha, isDigit)
 import Data.List (partition)
 import Data.Maybe (fromJust, fromMaybe)
-import qualified Data.Text as T (Text, append, tail, isPrefixOf, toUpper, filter, snoc, take)
+import qualified Data.Text as T (Text, append, tail, isPrefixOf, toUpper, filter, snoc, take, unpack)
 import Database.DataType ( ShapeType( Node ) , ShapeType( Hybrid ), ShapeType( BoolNode ))
 import Database.Persist.Sqlite (Entity, PersistEntity, SqlPersistM, PersistValue( PersistInt64 ), selectList,
                                 entityKey, entityVal, selectFirst, (==.), (<-.), get, keyToValues, PersistValue( PersistText ),
@@ -90,6 +93,24 @@ returnPost code = runDb $ do
         Nothing -> return Nothing
         Just post -> return $ Just $ entityVal post
 
+-- | Retrieves the course requirements for a Post as a list of course codes
+reqsForPost :: Post -> [String]
+reqsForPost post = do
+    let requirementsText = T.unpack $ postRequirements post
+        cleaned = filter (`notElem` ("<>" :: String)) $ filter (not . isPunctuation) requirementsText
+        potentialCodes = words cleaned
+    filter isCourseCode potentialCodes
+  where
+    -- | TODO: change function to use a regex
+    isCourseCode :: String -> Bool
+    isCourseCode codeStr = 
+        length codeStr == 8 && 
+        all isAlphaNum codeStr &&
+        all isAlpha (take 3 codeStr) &&
+        all isDigit (take 3 (drop 3 codeStr)) &&
+        isAlpha (codeStr !! 6) &&
+        isDigit (codeStr !! 7)
+
 -- | Queries the database for all information regarding a specific meeting for
 --  a @course@, returns a Meeting.
 returnMeeting :: T.Text -> T.Text -> T.Text -> SqlPersistM (Entity Meeting)

app/DynamicGraphs/GraphOptions.hs

@@ -15,7 +15,7 @@ data GraphOptions =
                    includeGrades :: Bool     -- True to include grade nodes
                 } deriving (Show)
 
-data CourseGraphOptions = CourseGraphOptions { courses :: [T.Text], graphOptions :: GraphOptions }
+data CourseGraphOptions = CourseGraphOptions { courses :: [T.Text], programs :: [T.Text], graphOptions :: GraphOptions }
   deriving (Show)
 
 defaultGraphOptions :: GraphOptions
@@ -33,6 +33,7 @@ defaultGraphOptions =
 instance FromJSON CourseGraphOptions where
   parseJSON = withObject "Expected Object for GraphOptions" $ \o -> do
     rootCourses <- o .:? "courses" .!= []
+    rootPrograms <- o.:? "programs" .!= []
     takenCourses <- o .:? "taken" .!= []
     dept <- o .:? "departments" .!= []
     excludedCourseDepth <- o .:? "excludedDepth" .!= 0
@@ -51,4 +52,4 @@ instance FromJSON CourseGraphOptions where
                                includedLocation
                                incRaws
                                incGrades
-    return $ CourseGraphOptions rootCourses options
+    return $ CourseGraphOptions rootCourses rootPrograms options

backend-test/Database/CourseQueriesTests.hs

@@ -0,0 +1,52 @@
+{-|
+Description: CourseQueries module tests.
+
+Module that contains the tests for the functions in the CourseQueries module.
+
+-}
+
+module Database.CourseQueriesTests
+( courseQueriesTestSuite
+) where
+
+import Config (runDb)
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.Text as T
+import Data.Time (getCurrentTime)
+import Database.CourseQueries (reqsForPost)
+import Database.DataType (PostType(..))
+import Database.Persist.Sqlite (insert_)
+import Database.Tables (Post(..))
+import Test.HUnit (Test(..), assertEqual)
+import TestHelpers (clearDatabase)
+
+-- | List of test cases as (label, requirements to insert, input program, expected output)
+reqsForPostTestCases :: [(String, T.Text, T.Text, String)]
+reqsForPostTestCases =
+    [ ("No program", "", "", "[]")
+    , ("Valid program", "/CSC199H1/", "ASMAJ1689", "[\"CSC199H1\"]")
+    , ("Invalid program", "", "ABCDE1234", "[]")
+    ]
+
+-- | Run a test case (case, requirements, input, expected output) on the reqsForPost function.
+runReqsForPostTest :: String -> T.Text -> T.Text -> String -> Test
+runReqsForPostTest label reqsToInsert program expected =
+    TestLabel label $ TestCase $ do
+        currentTime <- liftIO getCurrentTime
+        let testPost = Post Major "Computer Science" program "Sample post description" reqsToInsert currentTime currentTime
+
+        runDb $ do
+            clearDatabase
+            insert_ testPost
+
+        let requirements = reqsForPost testPost
+        let actual = show requirements
+        assertEqual ("Unexpected response body for " ++ label) expected actual
+
+-- | Run all the reqsForPost test cases
+runReqsForPostTests :: [Test]
+runReqsForPostTests = map (\(label, reqsToInsert, program, expected) -> runReqsForPostTest label reqsToInsert program expected) reqsForPostTestCases
+
+-- | Test suite for CourseQueries Module
+courseQueriesTestSuite :: Test
+courseQueriesTestSuite = TestLabel "Course Queries tests" $ TestList runReqsForPostTests

backend-test/Database/DatabaseTests.hs

@@ -0,0 +1,16 @@
+{-|
+Description: Database test suites module.
+
+Module that contains the test suites for all the database functions.
+
+-}
+
+module Database.DatabaseTests
+(  databaseTests  ) where
+
+import Test.HUnit (Test (..))
+import Database.CourseQueriesTests (courseQueriesTestSuite)
+
+-- Single test encompassing all database test suites
+databaseTests :: Test
+databaseTests = TestList [courseQueriesTestSuite]

backend-test/Main.hs

@@ -17,11 +17,12 @@ import qualified System.Exit as Exit
 import Test.HUnit (Test (..), failures, runTestTT)
 import RequirementTests.RequirementTests (requirementTests)
 import Controllers.ControllerTests (controllerTests)
+import Database.DatabaseTests (databaseTests)
 import SvgTests.SvgTests (svgTests)
 
 tests :: IO Test
 tests = do
-    return $ TestList [requirementTests, controllerTests, svgTests]
+    return $ TestList [requirementTests, controllerTests, svgTests, databaseTests]
 
 main :: IO ()
 main = do

courseography.cabal

@@ -106,7 +106,8 @@ test-suite Tests
     test-framework,
     test-framework-hunit,
     test-framework-quickcheck2,
-    text
+    text,
+    time
   default-extensions:
     OverloadedStrings,
     ScopedTypeVariables