schedule-planner 1.0.0.1 → 1.0.1.0
raw patch · 8 files changed
+193/−94 lines, 8 files
Files
- schedule-planner.cabal +28/−24
- src/Main.hs +31/−7
- src/SchedulePlanner.hs +13/−0
- src/SchedulePlanner/App.hs +10/−3
- src/SchedulePlanner/Calculator/Scale.hs +36/−18
- src/SchedulePlanner/Calculator/Solver.hs +35/−21
- src/SchedulePlanner/Serialize.hs +17/−13
- src/SchedulePlanner/Server.hs +23/−8
schedule-planner.cabal view
@@ -1,5 +1,5 @@ name: schedule-planner-version: 1.0.0.1+version: 1.0.1.0 cabal-version: >=1.10 build-type: Simple license: LGPL-3@@ -18,22 +18,24 @@ -- data-dir: "" 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+ 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@@ -48,20 +50,21 @@ 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+ 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@@ -75,11 +78,12 @@ -static -optl-pthread -optl-static- -O2 + source-repository head type: git location: git://github.com/JustusAdam/schedule-planner.git+ source-repository this type: git
src/Main.hs view
@@ -29,6 +29,9 @@ import qualified SchedulePlanner.Server as Server (server) +{-|+ If no input filename is provided, use this one.+-} stdFileName :: String stdFileName = "testsuite/test.json" @@ -38,24 +41,34 @@ outputFormatDefault = "print" +{-|+ If no server port is provided via command line flag, this one is used.+-} defaultServerPort :: Int defaultServerPort = 7097 +{-|+ Common options among all subcommands.+-} data CommonOptions = CommonOptions instance Options CommonOptions where defineOptions = pure CommonOptions --- |Command line options to choose from-data DirectCallOptions = DirectCallOptions { outputFile :: Maybe String- , inputFile :: String- , outputFormat :: String- , verbocity :: Bool- } deriving (Show) +{-|+ 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 ...+ } deriving (Show) + instance Options DirectCallOptions where defineOptions = DirectCallOptions <$> defineOption@@ -88,7 +101,12 @@ }) -data ServerOptions = ServerOptions { port :: Int }+{-|+ Options used for the "serve" subcommand.+-}+data ServerOptions = ServerOptions+ { port :: Int -- ^ default 'defaultServerPort'+ } instance Options ServerOptions where@@ -113,6 +131,9 @@ , subcommand "serve" serverMain ] +{-|+ Main function of the "calc" subcommand.+-} directCall :: CommonOptions -> DirectCallOptions -> [String] -> IO () directCall _@@ -126,5 +147,8 @@ reportAndPrint (pack outForm) v +{-|+ Main function of the "serve" subcommand.+-} serverMain :: CommonOptions -> ServerOptions -> [String] -> IO () serverMain _ (ServerOptions { port = p }) _ = Server.server p serverCalculation
+ src/SchedulePlanner.hs view
@@ -0,0 +1,13 @@++{-|+Module : $Header$+Description : Collective umbrella module for the Application+Copyright : (c) Justus Adam, 2015+License : LGPL-3+Maintainer : development@justusadam.com+Stability : experimental+Portability : POSIX++No intrinsic use. Only harbors submodules.+-}+module SchedulePlanner () where
src/SchedulePlanner/App.hs view
@@ -25,9 +25,10 @@ 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 SchedulePlanner.Calculator (calcFromMap, mapToSubject, weigh,+ MappedSchedule) import SchedulePlanner.Serialize (DataFile (DataFile),- formatSchedule, shortSubject, scheduleToJson)+ formatSchedule, shortSubject, scheduleToJson) import Data.String (fromString) @@ -36,6 +37,9 @@ printDebug debugMode = when debugMode . tell . pack . show +{-|+ Calculation on internal data structures.+-} calculate :: DataFile -> Maybe [MappedSchedule Text] calculate (DataFile rules lessons) = let@@ -44,10 +48,13 @@ in calcFromMap mappedLessons +{-|+ Calculation wrapped into server I/O compatible data structures.+-} serverCalculation :: ByteString -> ByteString serverCalculation = either- (fromString . ("Error:" ++) . show )+ (fromString . ("Error:" ++) . show) (maybe "\"No schedule could be calculated\"" (encode . map scheduleToJson)
src/SchedulePlanner/Calculator/Scale.hs view
@@ -30,26 +30,39 @@ 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)+-- | The scope and target a 'Rule' whishes to influence+data Target = Slot Int+ | Day Int+ | Cell Int Int+ deriving (Show, Typeable, Data, Ord, Eq) --- |Type alias for more expressive function signature-type WeightMap = Map.Map Target Int--- |Type alias for structure holding the dynamic rules-type DynRuleMap a = Map.Map Target [a]+-- | Weight increase by 'severity' for all 'Lesson's in target+data Rule = Rule { target :: Target+ , severity :: Int+ } deriving (Show, Typeable, Data) --- |Scaffolding for a dynamic rule-class DynamicRule a where- trigger :: Lesson s -> WeightMap -> a -> (WeightMap, a)- getTriggerTarget :: a -> [Target]+-- | Dynamic rule with only one condition+data SimpleDynRule = SimpleDynRule { sDynTarget :: Target+ , sDynSeverity :: Int+ } deriving (Show) +-- | Type alias for more expressive function signature+type WeightMap = Map.Map Target Int+++-- | Type alias for structure holding the dynamic rules+type DynRuleMap a = Map.Map Target [a]+++-- | Scaffolding for a dynamic rule+class DynamicRule r where+ trigger :: Lesson s -> WeightMap -> r -> (WeightMap, r)+ getTriggerTarget :: r -> [Target]++ instance DynamicRule SimpleDynRule where trigger _ wMap (SimpleDynRule targ sev) = (Map.insertWith (+) targ sev wMap, SimpleDynRule targ sev)@@ -57,7 +70,7 @@ getTriggerTarget = return.sDynTarget --- |Recalculate the lesson weight tuple as a result of dynamic rules+-- | Recalculate the lesson weight tuple as a result of dynamic rules reCalcMaps :: DynamicRule a => Lesson s -> DynRuleMap a -> WeightMap -> (DynRuleMap a, WeightMap) reCalcMaps lesson = runState . (reCalcHelper lesson (Slot (timeslot lesson)) >=>@@ -65,6 +78,9 @@ reCalcHelper lesson (uncurry Cell (time lesson))) +{-|+ Stateful recalculation of the rule map triggered by a change.+-} reCalcHelper :: (DynamicRule a, Ord k) => Lesson s -> k@@ -103,12 +119,14 @@ l {weight = weight l + allTargeting l wm} +{-|+ Find the full weight impact from the rules on a specific lesson.+-} allTargeting :: Lesson s -> WeightMap -> Int-allTargeting l = pure (((+) .) . (+))- <*> Map.findWithDefault 0 (Slot $ timeslot l)+allTargeting l = (((+) .) . (+))+ <$> Map.findWithDefault 0 (Slot $ timeslot l) <*> Map.findWithDefault 0 (Day $ day l) <*> Map.findWithDefault 0 (uncurry Cell $ time l)- {-|
src/SchedulePlanner/Calculator/Solver.hs view
@@ -33,32 +33,41 @@ import Data.Typeable (Typeable) --- |Base datastructure for representing lessons-data Lesson s = Lesson {- timeslot :: Int,- day :: Int,- weight :: Int,- subject :: s-} deriving (Show, Eq, Ord, Typeable, Data)+-- | 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 Alias for readability+ maps lessons to their respective subject+-} type MappedLessons s = Map.Map s [Lesson s]--- |type Alias for readability--- (Slot, Day)+++{-|+ type Alias for readability+ (Slot, Day)+-} type Timeslot = (Int, Int)--- |type Alias for readability--- represents a schedule+++{-|+ type Alias for readability+ represents a schedule+-} type MappedSchedule s = Map.Map Timeslot (Lesson s) --- |Convenience function extracing the (day, timeslot) 'Tuple' from a 'Lesson'+-- | Convenience function extracing the (day, timeslot) 'Tuple' from a 'Lesson' time :: Lesson a -> Timeslot-time = pure (,) <*> day <*> timeslot+time = (,) <$> day <*> timeslot --- |Convenience function to obtain the total weight of a particular Schedule+-- | Convenience function to obtain the total weight of a particular Schedule totalWeight :: MappedSchedule a -> Int totalWeight = Map.foldl (+) 0 . Map.map weight @@ -67,7 +76,7 @@ Map a List of 'Lesson's to their respective subjects -} mapToSubject :: Ord s => [Lesson s] -> Map.Map s [Lesson s]-mapToSubject = Map.fromListWith (++) . map (pure (,) <*> subject <*> (:[]))+mapToSubject = Map.fromListWith (++) . map ((,) <$> subject <*> (:[])) {-|@@ -83,7 +92,9 @@ of lightest schedules by branching the evaluation at avery point where there is a timeslot collision -}-calcFromMap :: Ord s => Map.Map s [Lesson s] -> Maybe [MappedSchedule s]+calcFromMap :: Ord s+ => Map.Map s [Lesson s]+ -> Maybe [MappedSchedule s] calcFromMap mappedLessons | Map.null mappedLessons = Nothing | otherwise = reduceLists subjX sortedLessons Map.empty minList@@ -96,7 +107,12 @@ One of the essential calculation steps, reducing the subject lists and recursing the calculation -}-reduceLists :: Ord s => s -> MappedLessons s -> MappedSchedule s -> [s] -> Maybe [MappedSchedule s]+reduceLists :: Ord s+ => s+ -> MappedLessons s+ -> MappedSchedule s+ -> [s]+ -> Maybe [MappedSchedule s] reduceLists s mappedLessons schedules subjects = Map.lookup s mappedLessons >>= uncons >>= \(c, cs) -> calc' c (Map.insert s cs mappedLessons) schedules subjects@@ -108,12 +124,10 @@ -} calc' :: Ord s => Lesson s -> MappedLessons s -> MappedSchedule s -> [s] -> Maybe [MappedSchedule s] calc' x lists hourMap minList =- maybe maybeEnd splitCalc (Map.lookup (time x) hourMap)- where maybeEnd = maybe
src/SchedulePlanner/Serialize.hs view
@@ -37,42 +37,42 @@ --- |Key for the rules data in the json input+-- | Key for the rules data in the json input ruleKey :: Text ruleKey = "rules"--- |Key for the lesson data in the json input+-- | Key for the lesson data in the json input lessonKey :: Text lessonKey = "lessons"--- |Key for the scope property in Rule objects in the json input+-- | Key for the scope property in Rule objects in the json input scopeKey :: Text scopeKey = "scope"--- |Key for the severity property in Rule objects in the json input+-- | Key for the severity property in Rule objects in the json input severityKey :: Text severityKey = "severity"--- |Key for the day property in Rule objects in the json input+-- | Key for the day property in Rule objects in the json input ruleDayKey :: Text ruleDayKey = "day"--- |Key for the slot property in Rule objects in the json input+-- | Key for the slot property in Rule objects in the json input ruleSlotKey :: Text ruleSlotKey = "slot"--- |Key for the subject property in Lesson objects in the json input+-- | Key for the subject property in Lesson objects in the json input subjectKey :: Text subjectKey = "subject"--- |Key for the day property in Lesson objects in the json input+-- | Key for the day property in Lesson objects in the json input lessonDayKey :: Text lessonDayKey = "day"--- |Key for the slot property in Rule objects in the json input+-- | Key for the slot property in Rule objects in the json input lessonSlotKey :: Text lessonSlotKey = "slot" --- |How many days a week has+-- | How many days a week has daysPerWeek :: Int daysPerWeek = 7--- |The amount of imeslots each day+-- | The amount of imeslots each day slotsPerDay :: Int slotsPerDay = 7--- |The caracter width of a single slot in output+-- | The caracter width of a single slot in output cellWidth :: Int cellWidth = 20 @@ -120,7 +120,7 @@ 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 _ _ = error "unknown input" -- I am so sorry parseJSON _ = mzero @@ -130,6 +130,7 @@ <*> o .: lessonKey parseJSON _ = mzero + instance ToJSON DataFile where toJSON (DataFile r l) = object@@ -138,6 +139,9 @@ ] +{-|+ Convert a single 'MappedSchedule' to a JSON 'Value'+-} scheduleToJson :: ToJSON a => MappedSchedule a -> Value scheduleToJson = object . sequenceA [ (.=) lessonKey . Map.elems
src/SchedulePlanner/Server.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-} {-| Module : $Header$ Description : functions necessary for deploying the application as a webservice@@ -14,16 +13,32 @@ module SchedulePlanner.Server (server, app) where -import Network.Wai.Handler.Warp (run)-import Network.Wai (responseLBS, lazyRequestBody, Application)-import Data.ByteString.Lazy (ByteString)-import Network.HTTP.Types (status200)+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) +{-|+ The 'Application' used for the server instance.+-} app :: (ByteString -> ByteString) -> Application-app a request respond = do- body <- lazyRequestBody request- respond $ responseLBS status200 [] $ a body+app app' request respond =+ lazyRequestBody request >>=+ respond . responseLBS status200 headers . app'+ where+ headers = [+ ("Access-Control-Allow-Origin", "http://justus.science"),+ ("Access-Control-Allow-Methods", "POST"),+ ("Access-Control-Allow-Headers", "Content-Type")+ ] ++{-|+ Run the server.+-} server :: Int -> (ByteString -> ByteString) -> IO () server port = run port . app