diff --git a/schedule-planner.cabal b/schedule-planner.cabal --- a/schedule-planner.cabal +++ b/schedule-planner.cabal @@ -1,5 +1,5 @@ name: schedule-planner -version: 1.0.1.0 +version: 1.0.1.1 cabal-version: >=1.10 build-type: Simple license: LGPL-3 @@ -19,48 +19,45 @@ extra-source-files: README.md -executable schedule-planner - build-depends: - base >= 4.7 && <5, - containers >= 0.5, - aeson >= 0.8, - options >= 1.2, - transformers >= 0.4, - bytestring >= 0.10, - text >= 1.2, - warp >= 3.0, - wai >= 3.0, - mtl >= 2.2, - http-types >= 0.8 - main-is: Main.hs - buildable: True - other-modules: - SchedulePlanner - SchedulePlanner.App - SchedulePlanner.Calculator - SchedulePlanner.Serialize - SchedulePlanner.Server - SchedulePlanner.Calculator.Scale - SchedulePlanner.Calculator.Solver - default-language: Haskell2010 - hs-source-dirs: src - ghc-options: - -Wall +Flag NoScraper + Default: False +Flag Static + Default: False -executable schedule-planner-standalone - build-depends: - base >= 4.7 && <5, - containers >= 0.5, - aeson >= 0.8, - options >= 1.2, - transformers >= 0.4, - bytestring >= 0.10, - text >= 1.2, - warp >= 3.0, - wai >= 3.0, - mtl >= 2.2, - http-types >= 0.8 + +executable schedule-planner + if !flag(NoScraper) + build-depends: + base >= 4.7 && <5, + containers >= 0.5, + aeson >= 0.8, + options >= 1.2, + transformers >= 0.4, + bytestring >= 0.10, + text >= 1.2, + warp >= 3.0, + wai >= 3.0, + mtl >= 2.2, + http-types >= 0.8, + composition >= 1.0, + HTTP >= 4000.2, + text-icu >= 0.7 + else + build-depends: + base >= 4.7 && <5, + containers >= 0.5, + aeson >= 0.8, + options >= 1.2, + transformers >= 0.4, + bytestring >= 0.10, + text >= 1.2, + warp >= 3.0, + wai >= 3.0, + mtl >= 2.2, + http-types >= 0.8, + composition >= 1.0, + HTTP >= 4000.2 main-is: Main.hs buildable: True other-modules: @@ -69,15 +66,24 @@ SchedulePlanner.Calculator SchedulePlanner.Serialize SchedulePlanner.Server + SchedulePlanner.Types SchedulePlanner.Calculator.Scale SchedulePlanner.Calculator.Solver + SchedulePlanner.Scraper + SchedulePlanner.Scraper.TUDresden default-language: Haskell2010 hs-source-dirs: src - ghc-options: - -Wall - -static - -optl-pthread - -optl-static + if !flag(NoScraper) + cpp-options: "-DNOSCRAPER" + if !flag(Static) + ghc-options: + -Wall + else + ghc-options: + -Wall + -static + -optl-pthread + -optl-static source-repository head diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -12,21 +12,25 @@ This module takes care of reading all input and checking for correctness as well as providing useful feedback upon encountering errors. -} -module Main (main) where +module Main + ( main + , DirectCallOptions(..) + , CommonOptions(..) + , SP.ServerOptions(..) + ) where -import Data.Text (pack) -import Data.ByteString.Lazy (readFile) -import Options (Options, defineOption, - defineOptions, optionDefault, - optionDescription, optionLongFlags, - optionShortFlags, optionType_bool, - optionType_maybe, optionType_int, - optionType_string, runSubcommand, - subcommand) -import Prelude hiding (readFile) -import SchedulePlanner.App (reportAndPrint, serverCalculation) -import qualified SchedulePlanner.Server as Server (server) +import Data.ByteString.Lazy (readFile) +import Data.Text (pack) +import Options (Options, defineOption, defineOptions, + optionDefault, optionDescription, + optionLongFlags, optionShortFlags, + optionType_bool, optionType_int, + optionType_maybe, optionType_string, + runSubcommand, subcommand) +import Prelude hiding (readFile) +import qualified SchedulePlanner as SP (reportAndPrint, server, + serverCalculation, ServerOptions(..)) {-| @@ -62,10 +66,10 @@ Command line options for the "calc" subcommand. -} data DirectCallOptions = DirectCallOptions - { outputFile :: Maybe String -- ^ if provided writes the output into a file - , inputFile :: String -- ^ the file from which to read the input, default 'stdFileName' - , outputFormat :: String -- ^ supported formats are "print" and "json", default 'outputFormatDefault' - , verbocity :: Bool -- ^ not sure this does anything ... + { outputFile :: Maybe String -- ^ if provided writes the output into a file + , inputFile :: String -- ^ the file from which to read the input, default 'stdFileName' + , outputFormat :: String -- ^ supported formats are "print" and "json", default 'outputFormatDefault' + , verbocity :: Bool -- ^ not sure this does anything ... } deriving (Show) @@ -101,16 +105,8 @@ }) -{-| - Options used for the "serve" subcommand. --} -data ServerOptions = ServerOptions - { port :: Int -- ^ default 'defaultServerPort' - } - - -instance Options ServerOptions where - defineOptions = ServerOptions +instance Options SP.ServerOptions where + defineOptions = SP.ServerOptions <$> defineOption optionType_int (\o -> o { optionLongFlags = ["port"] @@ -118,6 +114,12 @@ , optionDescription = "The port to run the server on" , optionDefault = defaultServerPort }) + <*> defineOption + (optionType_maybe optionType_string) + (\o -> o { optionLongFlags = [ "logfile" ] + , optionShortFlags = "l" + , optionDescription = "Set a logfile to enable server request logging" + }) {-| @@ -141,14 +143,14 @@ { inputFile = ifile , outputFormat = outForm , verbocity = v + , outputFile = outFile }) _ - = readFile ifile >>= - reportAndPrint (pack outForm) v + = readFile ifile >>= SP.reportAndPrint (pack outForm) v outFile {-| Main function of the "serve" subcommand. -} -serverMain :: CommonOptions -> ServerOptions -> [String] -> IO () -serverMain _ (ServerOptions { port = p }) _ = Server.server p serverCalculation +serverMain :: CommonOptions -> SP.ServerOptions -> [String] -> IO () +serverMain _ so _ = SP.server so SP.serverCalculation diff --git a/src/SchedulePlanner.hs b/src/SchedulePlanner.hs --- a/src/SchedulePlanner.hs +++ b/src/SchedulePlanner.hs @@ -10,4 +10,13 @@ No intrinsic use. Only harbors submodules. -} -module SchedulePlanner () where +module SchedulePlanner + ( reportAndPrint + , serverCalculation + , server + , ServerOptions(..) + ) where + + +import SchedulePlanner.App (reportAndPrint, serverCalculation) +import SchedulePlanner.Server (server, ServerOptions(..)) diff --git a/src/SchedulePlanner/App.hs b/src/SchedulePlanner/App.hs --- a/src/SchedulePlanner/App.hs +++ b/src/SchedulePlanner/App.hs @@ -18,18 +18,20 @@ ) where +import Control.Arrow ((&&&)) import Control.Monad.Writer (Writer, runWriter, tell, when) import Data.Aeson (eitherDecode, encode) -import Data.ByteString.Lazy as LBS (toStrict, ByteString) +import Data.ByteString.Lazy as LBS (ByteString, toStrict) import qualified Data.Map as Map (elems, keys) +import Data.String (fromString) import Data.Text as T (Text, append, pack) import qualified Data.Text.Encoding (decodeUtf8) -import Data.Text.IO as TIO (putStrLn) -import SchedulePlanner.Calculator (calcFromMap, mapToSubject, weigh, - MappedSchedule) +import Data.Text.IO as TIO (putStrLn, writeFile) +import SchedulePlanner.Calculator (MappedSchedule(..), MappedLessons(..), calcFromMap, + mapToSubject, weigh) import SchedulePlanner.Serialize (DataFile (DataFile), - formatSchedule, shortSubject, scheduleToJson) -import Data.String (fromString) + formatSchedule, scheduleToJson, + shortSubject) -- |Print a string if debug is enabled @@ -42,10 +44,7 @@ -} calculate :: DataFile -> Maybe [MappedSchedule Text] calculate (DataFile rules lessons) = - let - weighted = weigh rules lessons - mappedLessons = mapToSubject weighted - in calcFromMap mappedLessons + calcFromMap $ mapToSubject $ weigh rules lessons {-| @@ -67,11 +66,7 @@ and returns a writer of any output created. -} reportAndExecute :: Text -> Bool -> DataFile -> Writer Text () -reportAndExecute outputFormat debugMode (DataFile rules lessons) = do - let weighted = weigh rules lessons - - let mappedLessons = mapToSubject weighted - +reportAndExecute outputFormat debugMode (DataFile rules lessons) = maybe (tell "Calculation failed, no valid schedule possible") @@ -90,7 +85,7 @@ tell "\n" tell "Legend:" - _ <- mapM (tell . pack . show . (pure (,) <*> shortSubject <*> id) ) (Map.keys mappedLessons) + _ <- mapM (tell . pack . show . (shortSubject &&& id) ) (Map.keys mlRaw) tell "\n" @@ -98,7 +93,7 @@ return () "json" -> do - tell $ Data.Text.Encoding.decodeUtf8 $ toStrict $ encode $ concatMap Map.elems calculated + tell $ Data.Text.Encoding.decodeUtf8 $ toStrict $ encode $ concatMap (Map.elems . unMapSchedule) calculated return () _ -> tell "invalid output format") @@ -106,15 +101,17 @@ (calcFromMap mappedLessons) where - pc = mapM (tell . append "\n\n" . formatSchedule) + weighted = weigh rules lessons + mappedLessons@(MappedLessons mlRaw) = mapToSubject weighted + pc = mapM (tell . append "\n\n" . formatSchedule) {-| perform the calculation and print the result to the command line -} -reportAndPrint :: Text -> Bool -> ByteString -> IO() -reportAndPrint outputFormat debugMode = - TIO.putStrLn . either +reportAndPrint :: Text -> Bool -> Maybe String -> ByteString -> IO() +reportAndPrint outputFormat debugMode outFile = + maybe TIO.putStrLn TIO.writeFile outFile . either (pack . ("Stopped execution due to a severe problem with the input data:" ++) . show) (snd . runWriter . reportAndExecute outputFormat debugMode) . eitherDecode diff --git a/src/SchedulePlanner/Calculator.hs b/src/SchedulePlanner/Calculator.hs --- a/src/SchedulePlanner/Calculator.hs +++ b/src/SchedulePlanner/Calculator.hs @@ -14,14 +14,11 @@ ( calcFromMap , calcFromList , totalWeight - , Lesson (..) - , Timeslot - , Target(..) - , Rule(..) , mapToSubject - , MappedSchedule + , MappedSchedule(..) + , MappedLessons(..) , weigh -) where + ) where import SchedulePlanner.Calculator.Scale import SchedulePlanner.Calculator.Solver diff --git a/src/SchedulePlanner/Calculator/Scale.hs b/src/SchedulePlanner/Calculator/Scale.hs --- a/src/SchedulePlanner/Calculator/Scale.hs +++ b/src/SchedulePlanner/Calculator/Scale.hs @@ -16,45 +16,27 @@ , Target(..) , calcMaps , WeightMap -) where + ) where +import Control.Arrow (second) import Control.Monad ((>=>)) import Control.Monad.Trans.State (State, get, put, runState) -import Data.Data (Data) +import Data.Composition ((.:)) import Data.List as List (mapAccumL) import qualified Data.Map as Map (Map, empty, findWithDefault, insert, insertWith, lookup) -import Data.Typeable (Typeable) -import SchedulePlanner.Calculator.Solver (Lesson (..), time, timeslot) - - --- | The scope and target a 'Rule' whishes to influence -data Target = Slot Int - | Day Int - | Cell Int Int - deriving (Show, Typeable, Data, Ord, Eq) - - --- | Weight increase by 'severity' for all 'Lesson's in target -data Rule = Rule { target :: Target - , severity :: Int - } deriving (Show, Typeable, Data) - - --- | Dynamic rule with only one condition -data SimpleDynRule = SimpleDynRule { sDynTarget :: Target - , sDynSeverity :: Int - } deriving (Show) +import SchedulePlanner.Calculator.Solver (time) +import SchedulePlanner.Types -- | Type alias for more expressive function signature -type WeightMap = Map.Map Target Int +newtype WeightMap = WeightMap { unWeightMap :: Map.Map Target Int } -- | Type alias for structure holding the dynamic rules -type DynRuleMap a = Map.Map Target [a] +newtype DynRuleMap a = DynRuleMap { unDynRuleMap :: Map.Map Target [a] } -- | Scaffolding for a dynamic rule @@ -64,39 +46,70 @@ instance DynamicRule SimpleDynRule where - trigger _ wMap (SimpleDynRule targ sev) = - (Map.insertWith (+) targ sev wMap, SimpleDynRule targ sev) + trigger _ (WeightMap wMap) (SimpleDynRule targ sev) = + (WeightMap $ Map.insertWith (+) targ sev wMap, SimpleDynRule targ sev) getTriggerTarget = return.sDynTarget -- | Recalculate the lesson weight tuple as a result of dynamic rules -reCalcMaps :: DynamicRule a => Lesson s -> DynRuleMap a -> WeightMap -> (DynRuleMap a, WeightMap) +reCalcMaps :: DynamicRule a + => Lesson s + -> DynRuleMap a + -> WeightMap + -> (DynRuleMap a, WeightMap) reCalcMaps lesson = runState . - (reCalcHelper lesson (Slot (timeslot lesson)) >=> - reCalcHelper lesson (Day (day lesson)) >=> - reCalcHelper lesson (uncurry Cell (time lesson))) + (reCalcHelper lesson (TSlot (timeslot lesson)) >=> + reCalcHelper lesson (TDay (day lesson)) >=> + reCalcHelper lesson (TCell (time lesson))) {-| Stateful recalculation of the rule map triggered by a change. -} -reCalcHelper :: (DynamicRule a, Ord k) - => Lesson s - -> k - -> Map.Map k [a] - -> State WeightMap (Map.Map k [a]) +reCalcHelper :: DynamicRule a + => Lesson s + -> Target + -> DynRuleMap a + -> State WeightMap (DynRuleMap a) reCalcHelper inserted key = - pure maybe - <*> return - <*> (\rMap rules -> do - s <- get - let (newState, newRules) = mapAccumL (trigger inserted) s rules - put newState - return $ Map.insert key newRules rMap) - <*> Map.lookup key + maybe <$> return <*> f . unDynRuleMap <*> Map.lookup key . unDynRuleMap + where + f rMap rules = do + currentWeightMap <- get + let (newState, newRules) = mapAccumL (trigger inserted) currentWeightMap rules + put newState + return $ DynRuleMap $ Map.insert key newRules rMap +nonStateReCalcMaps :: DynamicRule a + => Lesson s + -> WeightMap + -> DynRuleMap a + -> (WeightMap, DynRuleMap a) +nonStateReCalcMaps lesson wm drm = + foldr (nonStateReCalcHelper lesson) (wm, drm) (constrTargets lesson) + + +nonStateReCalcHelper :: DynamicRule a + => Lesson s + -> Target + -> (WeightMap, DynRuleMap a) + -> (WeightMap, DynRuleMap a) +nonStateReCalcHelper inserted key (wm, pdrm@(DynRuleMap drm)) = + maybe (wm, pdrm) f $ Map.lookup key drm + where + f = second (DynRuleMap . flip (Map.insert key) drm) . mapAccumL (trigger inserted) wm + + +constrTargets :: Lesson a -> [Target] +constrTargets = sequenceA + [ TSlot . timeslot + , TDay . day + , TCell . time + ] + + {-| Main function of the module. @@ -123,10 +136,10 @@ Find the full weight impact from the rules on a specific lesson. -} allTargeting :: Lesson s -> WeightMap -> Int -allTargeting l = (((+) .) . (+)) - <$> Map.findWithDefault 0 (Slot $ timeslot l) - <*> Map.findWithDefault 0 (Day $ day l) - <*> Map.findWithDefault 0 (uncurry Cell $ time l) +allTargeting = (sum .: (sequenceA <<.> unWeightMap)) . + (map (Map.findWithDefault 0) . constrTargets) + where + f <<.> g = \a -> f a . g {-| @@ -134,7 +147,7 @@ weighing afterwards -} calcMaps :: [Rule] -> WeightMap -calcMaps = flip calcMapsStep Map.empty +calcMaps = flip calcMapsStep (WeightMap Map.empty) {-| @@ -142,4 +155,4 @@ -} calcMapsStep :: [Rule] -> WeightMap -> WeightMap calcMapsStep [] = id -calcMapsStep (Rule t sev :xs) = calcMapsStep xs . Map.insertWith (+) t sev +calcMapsStep (Rule t sev :xs) = calcMapsStep xs . WeightMap . Map.insertWith (+) t sev . unWeightMap diff --git a/src/SchedulePlanner/Calculator/Solver.hs b/src/SchedulePlanner/Calculator/Solver.hs --- a/src/SchedulePlanner/Calculator/Solver.hs +++ b/src/SchedulePlanner/Calculator/Solver.hs @@ -18,72 +18,56 @@ , mapToSubject , totalWeight , time - , Lesson (..) - , Timeslot - , MappedSchedule - , MappedLessons + , MappedSchedule(..) + , MappedLessons(..) ) where -import Data.Data (Data) -import Data.List as List (sortBy, uncons) -import qualified Data.Map as Map (Map, empty, foldl, fromListWith, insert, - keys, lookup, map, null) -import Data.Maybe (fromMaybe) -import qualified Data.Ord as Ord (comparing) -import Data.Typeable (Typeable) +import Control.Arrow ((&&&)) +import Data.List as List (sortBy, uncons) +import qualified Data.Map as Map (Map, empty, foldl, fromListWith, + insert, keys, lookup, map, null) +import Data.Maybe (fromMaybe) +import qualified Data.Ord as Ord (comparing) +import SchedulePlanner.Types --- | Base datastructure for representing lessons -data Lesson s = Lesson { timeslot :: Int - , day :: Int - , weight :: Int - , subject :: s - } deriving (Show, Eq, Ord, Typeable, Data) - {-| type Alias for readability maps lessons to their respective subject -} -type MappedLessons s = Map.Map s [Lesson s] - - -{-| - type Alias for readability - (Slot, Day) --} -type Timeslot = (Int, Int) +newtype MappedLessons s = MappedLessons { unMapLessons :: Map.Map s [Lesson s] } {-| type Alias for readability represents a schedule -} -type MappedSchedule s = Map.Map Timeslot (Lesson s) +newtype MappedSchedule s = MappedSchedule { unMapSchedule :: Map.Map Cell (Lesson s) } -- | Convenience function extracing the (day, timeslot) 'Tuple' from a 'Lesson' -time :: Lesson a -> Timeslot -time = (,) <$> day <*> timeslot +time :: Lesson a -> Cell +time = Cell . (day &&& timeslot) -- | Convenience function to obtain the total weight of a particular Schedule totalWeight :: MappedSchedule a -> Int -totalWeight = Map.foldl (+) 0 . Map.map weight +totalWeight = Map.foldl (+) 0 . Map.map weight . unMapSchedule {-| Map a List of 'Lesson's to their respective subjects -} -mapToSubject :: Ord s => [Lesson s] -> Map.Map s [Lesson s] -mapToSubject = Map.fromListWith (++) . map ((,) <$> subject <*> (:[])) +mapToSubject :: Ord s => [Lesson s] -> MappedLessons s +mapToSubject = MappedLessons . Map.fromListWith (++) . map (subject &&& (:[])) {-| Same as 'calcFromMap' but operates on a List of 'Lesson's -} calcFromList :: Ord s => [Lesson s] -> Maybe [MappedSchedule s] -calcFromList = calcFromMap.mapToSubject +calcFromList = calcFromMap . mapToSubject {-| @@ -93,14 +77,14 @@ where there is a timeslot collision -} calcFromMap :: Ord s - => Map.Map s [Lesson s] + => MappedLessons s -> Maybe [MappedSchedule s] -calcFromMap mappedLessons +calcFromMap (MappedLessons mappedLessons) | Map.null mappedLessons = Nothing - | otherwise = reduceLists subjX sortedLessons Map.empty minList + | otherwise = reduceLists subjX (MappedLessons sortedLessons) (MappedSchedule Map.empty) minList where - sortedLessons = Map.map (List.sortBy (Ord.comparing weight)) mappedLessons - (subjX : minList) = Map.keys sortedLessons + sortedLessons = Map.map (List.sortBy (Ord.comparing weight)) mappedLessons + (subjX : minList) = Map.keys sortedLessons {-| @@ -113,17 +97,22 @@ -> MappedSchedule s -> [s] -> Maybe [MappedSchedule s] -reduceLists s mappedLessons schedules subjects = +reduceLists s (MappedLessons mappedLessons) schedules subjects = Map.lookup s mappedLessons >>= uncons >>= - \(c, cs) -> calc' c (Map.insert s cs mappedLessons) schedules subjects + \(c, cs) -> calc' c (MappedLessons $ Map.insert s cs mappedLessons) schedules subjects {-| Helper function for 'calcFromMap' represents a recusively called and forking calculation step -} -calc' :: Ord s => Lesson s -> MappedLessons s -> MappedSchedule s -> [s] -> Maybe [MappedSchedule s] -calc' x lists hourMap minList = +calc' :: Ord s + => Lesson s + -> MappedLessons s + -> MappedSchedule s + -> [s] + -> Maybe [MappedSchedule s] +calc' x lists (MappedSchedule hourMap) minList = maybe maybeEnd splitCalc @@ -137,6 +126,6 @@ sideCalc element aMap = fromMaybe [] (reduceLists (subject element) lists aMap minList) - splitCalc old = return $ sideCalc x hourMap ++ sideCalc old newMap + splitCalc old = return $ sideCalc x (MappedSchedule hourMap) ++ sideCalc old newMap - newMap = Map.insert (time x) x hourMap + newMap = MappedSchedule $ Map.insert (time x) x hourMap diff --git a/src/SchedulePlanner/Scraper.hs b/src/SchedulePlanner/Scraper.hs new file mode 100644 --- /dev/null +++ b/src/SchedulePlanner/Scraper.hs @@ -0,0 +1,6 @@ +module SchedulePlanner.Scraper + ( scrapeTuDresden + ) where + + +import SchedulePlanner.Scraper.TUDresden diff --git a/src/SchedulePlanner/Scraper/TUDresden.hs b/src/SchedulePlanner/Scraper/TUDresden.hs new file mode 100644 --- /dev/null +++ b/src/SchedulePlanner/Scraper/TUDresden.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} +module SchedulePlanner.Scraper.TUDresden (scrapeTuDresden) where + + +import Control.Arrow +import Control.Monad +import Data.Bool +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Text as T +import Data.Text.ICU +import Network.HTTP +import Network.Stream +import SchedulePlanner.Types (Day (..), Lesson (..), Slot (..)) + + +grabTableRegex :: Int -> Regex +grabTableRegex = regex [DotAll] . T.append "

" . flip T.append ". Semester

.*?(.*?)
" . T.pack . show +trRegex :: Regex +trRegex = regex [DotAll] "(.*?)" +tdRegex :: Regex +tdRegex = regex [DotAll] "(.*?)" +aRegex :: Regex +aRegex = regex [DotAll] "(.*?)" +brRegex :: Regex +brRegex = regex [DotAll] " (.*?)
" + + +days :: Map.Map T.Text Int +days = Map.fromList + [ ("Montag", 1) + , ("Dienstag", 2) + , ("Mittwoch", 3) + , ("Donnerstag", 4) + , ("Freitag", 5) + , ("Samstag", 6) + , ("Sonntag", 7) + ] + + +uncons :: [a] -> Maybe (a, [a]) +uncons [] = Nothing +uncons (a:as) = Just (a,as) + + +retry :: Int -> IO (Either a b) -> IO (Either a b) +retry i a = a >>= doIt i + where + doIt _ v@(Right _) = return v + doIt i v@(Left _) + | i <= 0 = return v + | otherwise = a >>= doIt (i-1) + + +tuDresdenRequestUrl :: Request_String +tuDresdenRequestUrl = getRequest "http://web.inf.tu-dresden.de/Fak/ss/15/studiengang/studiengang_inf_bach.html" + + +stdRetries :: Int +stdRetries = 4 + + +getPage :: IO (Result (Response String)) +getPage = simpleHTTP tuDresdenRequestUrl + + +handleSubject :: [T.Text] -> [Lesson T.Text] +handleSubject (a:_:_:_:_:_:b:c:d:_) = + fromMaybe [] $ do + name <- find brRegex a `mplus` find aRegex a >>= group 1 + return $ fst $ foldr (flip $ uncurry (handleLesson name)) ([], 1) $ zip3 (splitBr b) (splitBr c) (splitBr d) + where + splitBr = join . map (T.splitOn "
") . T.splitOn "
" + +handleSubject _ = [] + + +handleLesson :: T.Text -> [Lesson T.Text] -> Int -> (T.Text, T.Text, T.Text) -> ([Lesson T.Text], Int) +handleLesson name other lectureNumber (ckind, cday, cslot) = + uncurry (***) (maybe (id, id) ((:) *** (+)) calculationResult) (other, lectureNumber) + where + calculationResult = constructLesson <$> Map.lookup (T.filter (== ' ') cday) days + + constructLesson mday = + ( Lesson + { subject = name `T.append` identifier + , day = Day mday + , timeslot = Slot $ read $ T.unpack $ T.filter (`elem` [' ', '.']) cslot + , weight = 0 + } + , bool 0 1 isLecture) + isLecture = ckind == "V" + exerciseID = " UE" + lectureID = " VL" `T.append` T.pack (show lectureNumber) + identifier = bool exerciseID lectureID isLecture +handleLesson _ other lectureNumber _ = (other, lectureNumber) + + +toLesson :: Int -> Response String -> Either String [Lesson T.Text] +toLesson n (Response { rspBody = r }) = maybe (Left "No parse") (Right . join . map handleSubject) lessons + where + table = find (grabTableRegex n) (T.pack r) >>= group 1 + rawLessons = snd <$> ((mapMaybe (group 1) . findAll trRegex <$> table) >>= uncons) + lessons = map (mapMaybe (group 1) . findAll tdRegex) <$> rawLessons + + +scrapeTuDresden :: Int -> IO (Either String [Lesson T.Text]) +scrapeTuDresden n = either (Left . show) (toLesson n) <$> retry stdRetries getPage diff --git a/src/SchedulePlanner/Serialize.hs b/src/SchedulePlanner/Serialize.hs --- a/src/SchedulePlanner/Serialize.hs +++ b/src/SchedulePlanner/Serialize.hs @@ -19,21 +19,20 @@ , scheduleToJson ) where -import Control.Arrow as Arrow (first) +import Control.Arrow as Arrow (first, second, (***)) +import Control.Monad (mzero) import Data.Aeson (FromJSON, Object, ToJSON, - Value (Object), decode, encode, + Value (Object), eitherDecode, object, parseJSON, toJSON, (.:), - (.=), eitherDecode) + (.=)) import Data.Aeson.Types (Parser) -import qualified Data.ByteString.Lazy as LBS (readFile, writeFile) +import qualified Data.Composition as Comp ((.:)) import Data.List as List (intercalate) -import qualified Data.Map as Map (Map, lookup, toList, elems) -import Data.Text as T (Text, pack) -import SchedulePlanner.Calculator (Lesson (..), MappedSchedule, - Rule (..), Target (..), Timeslot, - timeslot, totalWeight) +import qualified Data.Map as Map (Map, elems, lookup, toList) +import Data.Text as T (Text, pack, unpack) +import SchedulePlanner.Calculator (MappedSchedule (..), totalWeight) +import SchedulePlanner.Types import Text.Printf (printf) -import Control.Monad (mzero) @@ -64,8 +63,20 @@ -- | Key for the slot property in Rule objects in the json input lessonSlotKey :: Text lessonSlotKey = "slot" +-- | Value used in the "scope" attribute in json to indicate a slot being the target +scopeSlotVal :: Text +scopeSlotVal = "slot" +-- | Value used in the "scope" attribute in json to indicate a day being the target +scopeDayVal :: Text +scopeDayVal = "day" +-- | Value used in the "scope" attribute in json to indicate a cell being the target +scopeCellVal :: Text +scopeCellVal = "cell" +scheduleWeightKey :: Text +scheduleWeightKey = "weight" + -- | How many days a week has daysPerWeek :: Int daysPerWeek = 7 @@ -83,8 +94,8 @@ instance FromJSON a => FromJSON (Lesson a) where parseJSON (Object o) = Lesson - <$> o .: lessonSlotKey - <*> o .: lessonDayKey + <$> (Slot <$> o .: lessonSlotKey) + <*> (Day <$> o .: lessonDayKey) <*> pure 0 <*> o .: subjectKey parseJSON _ = mzero @@ -93,8 +104,8 @@ instance ToJSON a => ToJSON (Lesson a) where toJSON = object . sequenceA - [ (.=) lessonSlotKey . timeslot - , (.=) lessonDayKey . day + [ (.=) lessonSlotKey . unSlot . timeslot + , (.=) lessonDayKey . unDay . day , (.=) subjectKey . subject ] @@ -106,9 +117,15 @@ <*> uncurry (:) . Arrow.first (scopeKey .=) . getTarget . target) where getTarget :: Target -> (Text, [(Text, Value)]) - getTarget (Day d) = ("day", [ruleDayKey .= d]) - getTarget (Cell d s) = ("cell", [ruleDayKey .= d, ruleSlotKey .= s]) - getTarget (Slot s) = ("slot", [ruleSlotKey .= s]) + getTarget (TDay d) = (scopeDayVal, [ruleDayKey .= unDay d]) + getTarget (TCell c) = + second + ( sequenceA + [ (ruleDayKey .=) . unDay . fst + , (ruleSlotKey .=) . unSlot . snd + ]) + (scopeCellVal, unCell c) + getTarget (TSlot s) = (scopeSlotVal, [ruleSlotKey .= unSlot s]) instance FromJSON Rule where @@ -117,10 +134,13 @@ <*> o .: severityKey where fromScope :: Object -> Text -> Parser Target - fromScope obj "day" = Day <$> obj .: ruleDayKey - fromScope obj "slot" = Slot <$> obj .: ruleSlotKey - fromScope obj "cell" = Cell <$> obj .: ruleDayKey <*> obj .: ruleSlotKey - fromScope _ _ = error "unknown input" -- I am so sorry + fromScope obj scope + | scope == scopeDayVal = (TDay . Day) <$> obj .: ruleDayKey + | scope == scopeSlotVal = (TSlot . Slot) <$> obj .: ruleSlotKey + | scope == scopeCellVal = ((TCell . Cell) Comp..: curry (Day *** Slot)) + <$> obj .: ruleDayKey + <*> obj .: ruleSlotKey + | otherwise = error $ "unknown scope " ++ unpack scope -- I am so sorry parseJSON _ = mzero @@ -144,8 +164,8 @@ -} scheduleToJson :: ToJSON a => MappedSchedule a -> Value scheduleToJson = object . sequenceA - [ (.=) lessonKey . Map.elems - , (.=) "weight" . totalWeight + [ (.=) lessonKey . Map.elems . unMapSchedule + , (.=) scheduleWeightKey . totalWeight ] @@ -153,16 +173,7 @@ mapToJSON :: ToJSON a => Map.Map Text a -> Value mapToJSON = object . map (uncurry (.=)) . Map.toList --- |Open a file and return the contents as parsed json -getFromFile :: FilePath -> IO(Maybe DataFile) -getFromFile = fmap decode . LBS.readFile - --- |Open a file and write json to it -writeToFile :: ToJSON a => FilePath -> Map.Map Text a -> IO() -writeToFile filename = LBS.writeFile filename . encode . mapToJSON - - -- |Shorten a subject to something printable shortSubject :: Show s => s -> String shortSubject = reverse . take cellWidth . reverse . show @@ -173,15 +184,15 @@ and more importantly, readable Text -} formatSchedule :: Show s => MappedSchedule s -> Text -formatSchedule hours = pack $ List.intercalate "\n" $ header : map formatDay allHours +formatSchedule (MappedSchedule hours) = pack $ List.intercalate "\n" $ header : map formatDay allHours where allHours = [(i, [1..slotsPerDay]) | i <- [1..daysPerWeek]] - formatLesson :: Timeslot -> String + formatLesson :: Cell -> String formatLesson i = printf ("%" ++ show cellWidth ++ "v") $ maybe [] (shortSubject . subject) (Map.lookup i hours) formatDay :: (Int, [Int]) -> String - formatDay (i, l) = List.intercalate " | " [formatLesson (j, i) | j <- l] + formatDay (i, l) = List.intercalate " | " [formatLesson $ Cell (Day j, Slot i) | j <- l] - header = printf "Total Weight: %10v" (totalWeight hours) + header = printf "Total Weight: %10v" (totalWeight (MappedSchedule hours)) diff --git a/src/SchedulePlanner/Server.hs b/src/SchedulePlanner/Server.hs --- a/src/SchedulePlanner/Server.hs +++ b/src/SchedulePlanner/Server.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} {-| Module : $Header$ Description : functions necessary for deploying the application as a webservice @@ -8,37 +9,81 @@ Stability : experimental Portability : POSIX -Uses happstack and blaze to create a deployable service instance of this software. +Uses wai and warp to create a deployable web service instance of this software. -} -module SchedulePlanner.Server (server, app) where +module SchedulePlanner.Server (server, app, ServerOptions(..)) where -import Network.Wai.Handler.Warp (run) -import Network.Wai (responseLBS, lazyRequestBody, - Application, requestHeaders) -import Data.ByteString.Lazy (ByteString) -import Network.HTTP.Types (status200, HeaderName, Header, - methodPost, methodOptions) -import qualified Data.ByteString as BS (ByteString, intercalate) +import Data.ByteString.Lazy (ByteString) +import Network.HTTP.Types (Header, imATeaPot418, methodOptions, + methodPost, ok200) +import Network.Wai (Application, lazyRequestBody, + remoteHost, requestMethod, + responseLBS) +import Network.Wai.Handler.Warp (run) +#ifndef NOSCRAPER +import SchedulePlanner.Scraper +#endif +import System.IO (IOMode (AppendMode), hPutStrLn, + withFile) +defaultHeaders :: [Header] +defaultHeaders = + [ ("Access-Control-Allow-Origin" , "http://justus.science") + , ("Access-Control-Allow-Methods", "POST") + , ("Access-Control-Allow-Headers", "Content-Type") + ] + + {-| + Options used for the "serve" subcommand. +-} +data ServerOptions = ServerOptions + { port :: Int -- ^ default 'defaultServerPort' + , logFile :: Maybe FilePath + } + + +writeToLog :: FilePath -> String -> IO () +writeToLog logfile = withFile logfile AppendMode . flip hPutStrLn + + +{-| The 'Application' used for the server instance. -} -app :: (ByteString -> ByteString) -> Application -app app' request respond = - lazyRequestBody request >>= - respond . responseLBS status200 headers . app' +app :: ServerOptions -> (ByteString -> ByteString) -> Application +app opts app' request respond + | rMethod == methodPost = + logPureReq ("New POST request from " ++ (show $ remoteHost request)) >> + lazyRequestBody request >>= + respond . responseLBS ok200 headers . app' + | rMethod == methodOptions = respond $ responseLBS ok200 headers "Bring it!" + | otherwise = + logPureReq ("Unhandleable request: " ++ show request) >> + respond (responseLBS imATeaPot418 [] "What are you doing to an innocent teapot?") where - headers = [ - ("Access-Control-Allow-Origin", "http://justus.science"), - ("Access-Control-Allow-Methods", "POST"), - ("Access-Control-Allow-Headers", "Content-Type") - ] + logAction logfile = withFile logfile AppendMode . flip hPutStrLn + logPureReq message = + maybe + (return ()) + (flip logAction message) + (logFile opts) + logIOReq messageGetter = + maybe + (return ()) + ((>>=) messageGetter . logAction) + (logFile opts) + rMethod = requestMethod request + headers = defaultHeaders {-| Run the server. -} -server :: Int -> (ByteString -> ByteString) -> IO () -server port = run port . app +server :: ServerOptions -> (ByteString -> ByteString) -> IO () +server opts@(ServerOptions { port = port, logFile = logfile }) = + (>>) (maybe (return ()) logInit logfile) . run port . app opts + where + logInit = flip writeToLog $ "Server starting on port " ++ show port + diff --git a/src/SchedulePlanner/Types.hs b/src/SchedulePlanner/Types.hs new file mode 100644 --- /dev/null +++ b/src/SchedulePlanner/Types.hs @@ -0,0 +1,57 @@ +{-| +Module : $Header$ +Description : Basic types used internally by this software +Copyright : (c) Justus Adam, 2015 +License : LGPL-3 +Maintainer : development@justusadam.com +Stability : experimental +Portability : POSIX + +Custom types the software uses. +-} +module SchedulePlanner.Types + ( Slot(..) + , Day(..) + , Cell(..) + , Lesson(..) + , Target(..) + , Rule(..) + , SimpleDynRule(..) + ) where + + +import Data.Typeable + + +newtype Slot = Slot { unSlot :: Int } deriving (Eq, Show, Ord) + +newtype Day = Day { unDay :: Int } deriving (Eq, Show, Ord) + +newtype Cell = Cell { unCell :: (Day, Slot) } deriving (Eq, Show, Ord) + + +-- | Base datastructure for representing lessons +data Lesson s = Lesson { timeslot :: Slot + , day :: Day + , weight :: Int + , subject :: s + } deriving (Show, Eq, Ord, Typeable) + + +-- | The scope and target a 'Rule' whishes to influence +data Target = TSlot Slot + | TDay Day + | TCell Cell + deriving (Show, Typeable, Ord, Eq) + + +-- | Weight increase by 'severity' for all 'Lesson's in target +data Rule = Rule { target :: Target + , severity :: Int + } deriving (Show, Typeable) + + +-- | Dynamic rule with only one condition +data SimpleDynRule = SimpleDynRule { sDynTarget :: Target + , sDynSeverity :: Int + } deriving (Show)