schedule-planner 1.0.1.0 → 1.0.1.1
raw patch · 12 files changed
+496/−256 lines, 12 filesdep +HTTPdep +compositiondep +text-icu
Dependencies added: HTTP, composition, text-icu
Files
- schedule-planner.cabal +52/−46
- src/Main.hs +33/−31
- src/SchedulePlanner.hs +10/−1
- src/SchedulePlanner/App.hs +18/−21
- src/SchedulePlanner/Calculator.hs +3/−6
- src/SchedulePlanner/Calculator/Scale.hs +63/−50
- src/SchedulePlanner/Calculator/Solver.hs +33/−44
- src/SchedulePlanner/Scraper.hs +6/−0
- src/SchedulePlanner/Scraper/TUDresden.hs +108/−0
- src/SchedulePlanner/Serialize.hs +47/−36
- src/SchedulePlanner/Server.hs +66/−21
- src/SchedulePlanner/Types.hs +57/−0
schedule-planner.cabal view
@@ -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
src/Main.hs view
@@ -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
src/SchedulePlanner.hs view
@@ -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(..))
src/SchedulePlanner/App.hs view
@@ -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
src/SchedulePlanner/Calculator.hs view
@@ -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
src/SchedulePlanner/Calculator/Scale.hs view
@@ -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
src/SchedulePlanner/Calculator/Solver.hs view
@@ -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
+ src/SchedulePlanner/Scraper.hs view
@@ -0,0 +1,6 @@+module SchedulePlanner.Scraper+ ( scrapeTuDresden+ ) where+++import SchedulePlanner.Scraper.TUDresden
+ src/SchedulePlanner/Scraper/TUDresden.hs view
@@ -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 "<h1>" . flip T.append ". Semester</h1>.*?<table>(.*?)</table>" . T.pack . show+trRegex :: Regex+trRegex = regex [DotAll] "<tr>(.*?)</tr>"+tdRegex :: Regex+tdRegex = regex [DotAll] "<td>(.*?)</td>"+aRegex :: Regex+aRegex = regex [DotAll] "<a .*?\">(.*?)</a>"+brRegex :: Regex+brRegex = regex [DotAll] " (.*?)<br ?/>"+++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 "<br/>") . T.splitOn "<br />"++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
src/SchedulePlanner/Serialize.hs view
@@ -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))
src/SchedulePlanner/Server.hs view
@@ -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+
+ src/SchedulePlanner/Types.hs view
@@ -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)