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.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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/SchedulePlanner.hs b/src/SchedulePlanner.hs new file mode 100644 --- /dev/null +++ b/src/SchedulePlanner.hs @@ -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 diff --git a/src/SchedulePlanner/App.hs b/src/SchedulePlanner/App.hs --- a/src/SchedulePlanner/App.hs +++ b/src/SchedulePlanner/App.hs @@ -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) 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 @@ -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) - {-| 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 @@ -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 diff --git a/src/SchedulePlanner/Serialize.hs b/src/SchedulePlanner/Serialize.hs --- a/src/SchedulePlanner/Serialize.hs +++ b/src/SchedulePlanner/Serialize.hs @@ -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 diff --git a/src/SchedulePlanner/Server.hs b/src/SchedulePlanner/Server.hs --- a/src/SchedulePlanner/Server.hs +++ b/src/SchedulePlanner/Server.hs @@ -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