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: 0.1.0.2 +version: 1.0.0.0 cabal-version: >=1.10 build-type: Simple license: LGPL-3 @@ -15,18 +15,22 @@ instance of this software is planned. category: Data, Convenience, Planning author: Justus Adam -data-dir: "" +-- data-dir: "" extra-source-files: README.md executable schedule-planner build-depends: base >= 4.7 && <5, - containers -any, - json -any, - options -any, - transformers > 0.4, - happstack-lite > 7, - mtl > 1 + 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: @@ -38,6 +42,8 @@ SchedulePlanner.Calculator.Solver default-language: Haskell2010 hs-source-dirs: src + ghc-options: + -Wall source-repository head type: git @@ -47,4 +53,4 @@ type: git branch: stable location: git://github.com/JustusAdam/schedule-planner.git - tag: 1.0.0 + tag: 1.0.0.0 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-| Module : $Header$ Description : Interface for schedule-planner @@ -11,76 +12,119 @@ This module takes care of reading all input and checking for correctness as well as providing useful feedback upon encountering errors. -} -module Main (main, CallOptions) where +module Main (main) where -import Control.Applicative (pure, (<*>)) -import Control.Monad (liftM, when) + +import Data.Text (pack) +import Data.ByteString.Lazy (readFile) import Options (Options, defineOption, defineOptions, optionDefault, optionDescription, optionLongFlags, optionShortFlags, optionType_bool, - optionType_maybe, - optionType_string, runCommand) -import SchedulePlanner.App -import SchedulePlanner.Calculator -import SchedulePlanner.Serialize + optionType_maybe, optionType_int, + optionType_string, runSubcommand, + subcommand) +import Prelude hiding (readFile) +import SchedulePlanner.App (reportAndPrint, serverCalculation) +import qualified SchedulePlanner.Server as Server (server) +stdFileName :: String +stdFileName = "testsuite/test.json" + + -- |Temporary constant, should be in call args eventually +outputFormatDefault :: String outputFormatDefault = "print" --- |Legacy hard coded name of inputfile -stdFileName = "testsuite/test.json" +defaultServerPort :: Int +defaultServerPort = 7097 -data CallOptions = CallOptions { - outputFile :: Maybe String, - inputFile :: String, - outputFormat :: String, - server :: Bool, - verbocity :: Bool - } deriving (Show) +data CommonOptions = CommonOptions -instance Options CallOptions where - defineOptions = pure CallOptions - <*> defineOption (optionType_maybe optionType_string) (\o -> o { - optionLongFlags = ["output-file"], - optionShortFlags = "o", - optionDescription = "print output to this file instead of stdout", - optionDefault = Nothing - }) - <*> defineOption optionType_string (\o -> o { - optionDefault = stdFileName, - optionLongFlags = ["input-file"], - optionShortFlags = "i", - optionDescription = "read input from this file" - }) - <*> defineOption optionType_string (\o -> o { - optionDefault = outputFormatDefault, - optionLongFlags = ["output-format"], - optionShortFlags = "f", - optionDescription = "set the output format" - }) - <*> defineOption optionType_bool (\o -> o { - optionDefault = False, - optionLongFlags = ["serve"], - optionDescription = "Placeholder with no effect yet" - }) - <*> defineOption optionType_bool (\o -> o { - optionDefault = False, - optionLongFlags = ["verbose"], - optionShortFlags = "v", - optionDescription = "Print extra information" - }) +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) + + +instance Options DirectCallOptions where + defineOptions = DirectCallOptions + <$> defineOption + (optionType_maybe optionType_string) + (\o -> o { optionLongFlags = ["output-file"] + , optionShortFlags = "o" + , optionDescription = "print output to this file instead of stdout" + , optionDefault = Nothing + }) + <*> defineOption + optionType_string + (\o -> o { optionDefault = stdFileName + , optionLongFlags = ["input-file"] + , optionShortFlags = "i" + , optionDescription = "read input from this file" + }) + <*> defineOption + optionType_string + (\o -> o { optionDefault = outputFormatDefault + , optionLongFlags = ["output-format"] + , optionShortFlags = "f" + , optionDescription = "set the output format" + }) + <*> defineOption + optionType_bool + (\o -> o { optionDefault = False + , optionLongFlags = ["verbose"] + , optionShortFlags = "v" + , optionDescription = "Print extra information" + }) + + +data ServerOptions = ServerOptions { port :: Int } + + +instance Options ServerOptions where + defineOptions = ServerOptions + <$> defineOption + optionType_int + (\o -> o { optionLongFlags = ["port"] + , optionShortFlags = "p" + , optionDescription = "The port to run the server on" + , optionDefault = defaultServerPort + }) + + {-| main function. Handles reading command line arguments, the json input and starts execution. -} main :: IO() -main = runCommand $ \opts args -> do - rawInput <- readFile (inputFile opts) +main = + runSubcommand + [ subcommand "calc" directCall + , subcommand "serve" serverMain + ] - reportAndPrint (outputFormat opts) (verbocity opts) rawInput +directCall :: CommonOptions -> DirectCallOptions -> [String] -> IO () +directCall + _ + ( DirectCallOptions + { inputFile = ifile + , outputFormat = outForm + , verbocity = v + }) + _ + = readFile ifile >>= + reportAndPrint (pack outForm) v + + +serverMain :: CommonOptions -> ServerOptions -> [String] -> IO () +serverMain _ (ServerOptions { port = p }) _ = Server.server p serverCalculation diff --git a/src/SchedulePlanner/App.hs b/src/SchedulePlanner/App.hs --- a/src/SchedulePlanner/App.hs +++ b/src/SchedulePlanner/App.hs @@ -1,52 +1,74 @@ -module SchedulePlanner.App ( - reportAndPrint, - reportAndExecute +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : $Header$ +Description : Connector from IO to logic +Copyright : (c) Justus Adam, 2015 +License : LGPL-3 +Maintainer : development@justusadam.com +Stability : experimental +Portability : POSIX + +Sort of the Main script for all the common operations, independant of the +program instance (webservice, command line) +-} +module SchedulePlanner.App + ( reportAndPrint + , reportAndExecute + , serverCalculation ) where -import Control.Applicative (pure, (<*>)) -import Control.Monad.Writer -import qualified Data.List as List (take) -import qualified Data.Map as Map (keys) -import Data.Maybe (fromMaybe) -import SchedulePlanner.Calculator -import SchedulePlanner.Serialize -import System.IO (hPutStrLn, stderr) -import Text.JSON as JSON (Result (..)) +import Control.Monad.Writer (Writer, runWriter, tell, when) +import Data.Aeson (eitherDecode, encode) +import Data.ByteString.Lazy as LBS (toStrict, ByteString) +import qualified Data.Map as Map (elems, keys) +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.Serialize (DataFile (DataFile), + formatSchedule, shortSubject) +import Data.String (fromString) +-- |Print a string if debug is enabled +printDebug :: Show a => Bool -> a -> Writer Text () +printDebug debugMode = when debugMode . tell . pack . show --- |Print a line to stdout -putErrorLine :: String -> IO() -putErrorLine = hPutStrLn stderr +calculate :: DataFile -> Maybe [MappedSchedule Text] +calculate (DataFile rules lessons) = + let + weighted = weigh rules lessons + mappedLessons = mapToSubject weighted + in calcFromMap mappedLessons --- |Print a string if debug is enabled -printDebug :: Show a => Bool -> a -> Writer String () -printDebug debugMode = when debugMode . tell . show +serverCalculation :: ByteString -> ByteString +serverCalculation = + either + (fromString . ("Error:" ++) . show ) + (maybe + "\"No schedule could be calculated\"" + (encode . concatMap Map.elems) + . calculate) + . eitherDecode + {-| - Evaluates the transformed json, compiles (useful) error messages, prints them - and then runs the algorithm or, if the errors are too severe, aborts. + Evaluates the transformed json, compiles (useful) error messages, runs the algorithm + and returns a writer of any output created. -} -reportAndExecute :: String -> Bool -> Result ([Result Rule], [Result (Lesson String)]) -> Writer String () -reportAndExecute _ _ (Error s) = - tell $ "Stopped execution due to a severe problem with the input data:" ++ show s -reportAndExecute outputFormat debugMode (Ok (r, l)) = do - rules <- reportOrReturn r - lessons <- reportOrReturn l - +reportAndExecute :: Text -> Bool -> DataFile -> Writer Text () +reportAndExecute outputFormat debugMode (DataFile rules lessons) = do let weighted = weigh rules lessons let mappedLessons = mapToSubject weighted - let result = calcFromMap mappedLessons + maybe + (tell "Calculation failed, no valid schedule possible") - case result of - Nothing -> - tell "Calculation failed, no valid schedule possible" - Just calculated -> + (\calculated -> case outputFormat of @@ -61,7 +83,7 @@ tell "\n" tell "Legend:" - _ <- mapM (tell . show . (pure (,) <*> shortSubject <*> id) ) (Map.keys mappedLessons) + _ <- mapM (tell . pack . show . (pure (,) <*> shortSubject <*> id) ) (Map.keys mappedLessons) tell "\n" @@ -69,23 +91,23 @@ return () "json" -> do - tell $ serialize calculated + tell $ Data.Text.Encoding.decodeUtf8 $ toStrict $ encode $ concatMap Map.elems calculated return () - where - pc = mapM (tell.("\n\n" ++).formatSchedule) + _ -> tell "invalid output format") - reportOrReturn :: [Result a] -> Writer String [a] - reportOrReturn [] = return [] - reportOrReturn (x:xs) = - case x of - Error s -> do - tell "Some data was unusable:" - tell s - reportOrReturn xs - Ok v -> liftM (v:) (reportOrReturn xs) + (calcFromMap mappedLessons) + where + pc = mapM (tell . append "\n\n" . formatSchedule) -reportAndPrint :: String -> Bool -> String -> IO() -reportAndPrint outputFormat debugMode rawInput = - putStrLn $ snd $ runWriter $ reportAndExecute outputFormat debugMode (deSerialize rawInput) + +{-| + perform the calculation and print the result to the command line +-} +reportAndPrint :: Text -> Bool -> ByteString -> IO() +reportAndPrint outputFormat debugMode = + TIO.putStrLn . 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 @@ -10,17 +10,17 @@ Exports the most important functions neccessary for the actual work of this software -} -module SchedulePlanner.Calculator( - calcFromMap, - calcFromList, - totalWeight, - Lesson (..), - Timeslot (..), - Target(..), - Rule(..), - mapToSubject, - MappedSchedule, - weigh +module SchedulePlanner.Calculator + ( calcFromMap + , calcFromList + , totalWeight + , Lesson (..) + , Timeslot + , Target(..) + , Rule(..) + , mapToSubject + , MappedSchedule + , weigh ) where import SchedulePlanner.Calculator.Scale 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 @@ -10,22 +10,22 @@ This module is used to weigh a list of lessons according to rules. -} -module SchedulePlanner.Calculator.Scale ( - weigh, - Rule(..), - Target(..), - calcMaps +module SchedulePlanner.Calculator.Scale + ( weigh + , Rule(..) + , Target(..) + , calcMaps + , WeightMap ) where -import Control.Applicative (pure, (<*>)) +import Control.Monad ((>=>)) import Control.Monad.Trans.State (State, get, put, runState) import Data.Data (Data) import Data.List as List (mapAccumL) import qualified Data.Map as Map (Map, empty, findWithDefault, insert, insertWith, - lookup, update) -import Data.Tuple (swap) + lookup) import Data.Typeable (Typeable) import SchedulePlanner.Calculator.Solver (Lesson (..), time, timeslot) @@ -41,7 +41,7 @@ -- |Type alias for more expressive function signature type WeightMap = Map.Map Target Int -- |Type alias for structure holding the dynamic rules -type DynRuleMap = Map.Map Target [SimpleDynRule] +type DynRuleMap a = Map.Map Target [a] -- |Scaffolding for a dynamic rule @@ -51,46 +51,34 @@ instance DynamicRule SimpleDynRule where - trigger inserted wMap (SimpleDynRule target sev) = - (Map.insertWith (+) target sev wMap, SimpleDynRule target sev) + trigger _ wMap (SimpleDynRule targ sev) = + (Map.insertWith (+) targ sev wMap, SimpleDynRule targ sev) getTriggerTarget = return.sDynTarget -- |Recalculate the lesson weight tuple as a result of dynamic rules -reCalcMaps :: WeightMap -> Lesson s -> DynRuleMap -> (DynRuleMap, WeightMap) -reCalcMaps weightMap lesson rules = runState ( - - reCalcHelper lesson (Slot (timeslot lesson)) rules >>= - reCalcHelper lesson (Day (day lesson)) >>= - reCalcHelper lesson (uncurry Cell (time lesson)) - - ) 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 :: Ord k +reCalcHelper :: (DynamicRule a, Ord k) => Lesson s -> k - -> Map.Map k [SimpleDynRule] - -> State WeightMap (Map.Map k [SimpleDynRule]) -reCalcHelper inserted key rMap = - case Map.lookup key rMap of - Nothing -> return rMap - Just rules -> do - s <- get - let (newState, newRules) = mapAccumL (trigger inserted) s rules - put newState - return $ Map.insert key newRules rMap - - --- |Apply a function to only the first element of a 2-tuple -applyToFirst :: (a -> c) -> (a, b) -> (c, b) -applyToFirst f (x, y) = (f x, y) - - --- |Apply a function to only the second element of a 2-tuple -applyToSecond :: (b -> c) -> (a, b) -> (a, c) -applyToSecond f (x, y) = (x, f y) + -> Map.Map k [a] + -> State WeightMap (Map.Map k [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 {-| @@ -103,7 +91,7 @@ component which is the old weight + the weight calculated from the rules -} weigh :: [Rule] -> [Lesson s] -> [Lesson s] -weigh rs = map (weighOne (calcMaps rs)) +weigh = map . weighOne . calcMaps {-| @@ -116,7 +104,7 @@ allTargeting :: Lesson s -> WeightMap -> Int -allTargeting l = pure (\a b c -> a + b + c) +allTargeting l = pure (((+) .) . (+)) <*> Map.findWithDefault 0 (Slot $ timeslot l) <*> Map.findWithDefault 0 (Day $ day l) <*> Map.findWithDefault 0 (uncurry Cell $ time l) @@ -128,7 +116,7 @@ weighing afterwards -} calcMaps :: [Rule] -> WeightMap -calcMaps = (`calcMapsStep` Map.empty) +calcMaps = flip calcMapsStep Map.empty {-| 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 @@ -12,27 +12,25 @@ schedule layout from weighted Lessons as well as providing functions for converting them into readable/printable format. -} -module SchedulePlanner.Calculator.Solver ( - calcFromMap, - calcFromList, - mapToSubject, - totalWeight, - time, - Lesson (..), - Timeslot (..), - MappedSchedule, - MappedLessons +module SchedulePlanner.Calculator.Solver + ( calcFromMap + , calcFromList + , mapToSubject + , totalWeight + , time + , Lesson (..) + , Timeslot + , MappedSchedule + , MappedLessons ) where -import Control.Applicative (pure, (<*>)) -import Data.Data (Data) -import Data.List as List (sortBy, take) -import qualified Data.Map as Map (Map, empty, foldl, fromList, - fromListWith, insert, keys, lookup, - map, null, toList) -import Data.Maybe (fromMaybe) -import qualified Data.Ord as Ord (comparing) -import Data.Typeable (Typeable) +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) -- |Base datastructure for representing lessons @@ -69,7 +67,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 (\x -> (subject x, [x])) +mapToSubject = Map.fromListWith (++) . map (pure (,) <*> subject <*> (:[])) {-| @@ -88,42 +86,43 @@ calcFromMap :: Ord s => Map.Map s [Lesson s] -> Maybe [MappedSchedule s] calcFromMap mappedLessons | Map.null mappedLessons = Nothing - | otherwise = Map.lookup subjX sortedLessons >>= - (\(x : xs) -> - calc' x (Map.insert subjX xs sortedLessons) Map.empty minList - ) + | otherwise = reduceLists subjX sortedLessons Map.empty minList where sortedLessons = Map.map (List.sortBy (Ord.comparing weight)) mappedLessons (subjX : minList) = Map.keys sortedLessons {-| + 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 s mappedLessons schedules subjects = + Map.lookup s mappedLessons >>= uncons >>= + \(c, cs) -> calc' c (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 = - case Map.lookup (time x) hourMap of - Nothing -> - case minList of - [] -> return [newMap] - (c : cs) -> Map.lookup c lists >>= - (\(l : ls) -> calc' l (Map.insert c ls lists) newMap cs) + maybe + maybeEnd + splitCalc + (Map.lookup (time x) hourMap) - Just old -> - return $ r1 ++ r2 - where - r1 = fromMaybe [] $ reduceLists (subject x) lists hourMap minList - r2 = fromMaybe [] $ reduceLists (subject old) lists newMap minList where - newMap = Map.insert (time x) x hourMap + maybeEnd = maybe + (return [newMap]) + (\(c, cs) -> reduceLists c lists newMap cs) + (uncons minList) - reduceLists :: Ord s => s -> MappedLessons s -> MappedSchedule s -> [s] -> Maybe [MappedSchedule s] - reduceLists s lists schedules subjects = Map.lookup s lists >>= - (\l -> - case l of - [] -> Nothing - (c : cs) -> calc' c (Map.insert s cs lists) schedules subjects - ) + sideCalc element aMap = fromMaybe [] (reduceLists (subject element) lists aMap minList) + + splitCalc old = return $ sideCalc x hourMap ++ sideCalc old newMap + + newMap = Map.insert (time x) x hourMap diff --git a/src/SchedulePlanner/Serialize.hs b/src/SchedulePlanner/Serialize.hs --- a/src/SchedulePlanner/Serialize.hs +++ b/src/SchedulePlanner/Serialize.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-| Module : $Header$ Description : (de)serializing in- and output @@ -9,156 +10,158 @@ Hold the capeablilities to get and export in- and output data as well as (de)serialize it -} -module SchedulePlanner.Serialize where +module SchedulePlanner.Serialize + ( mapToJSON + , formatSchedule + , shortSubject + , DataFile(DataFile) + , eitherDecode + ) where -import Control.Applicative (pure, (<*>)) -import Control.Monad (liftM) -import Data.List (intercalate) -import qualified Data.Map as Map (assocs, lookup) -import SchedulePlanner.Calculator -import Text.JSON as JSON (JSON, JSObject, JSValue (JSArray, JSObject), - Result (..), decodeStrict, - encode, showJSON, - toJSObject, valFromObj) +import Control.Arrow as Arrow (first) +import Data.Aeson (FromJSON, Object, ToJSON, + Value (Object), decode, encode, + object, parseJSON, toJSON, (.:), + (.=), eitherDecode) +import Data.Aeson.Types (Parser) +import qualified Data.ByteString.Lazy as LBS (readFile, writeFile) +import Data.List as List (intercalate) +import qualified Data.Map as Map (Map, lookup, toList) +import Data.Text as T (Text, pack) +import SchedulePlanner.Calculator (Lesson (..), MappedSchedule, + Rule (..), Target (..), Timeslot, + timeslot, totalWeight) import Text.Printf (printf) +import Control.Monad (mzero) -- |Key for the rules data in the json input +ruleKey :: Text ruleKey = "rules" -- |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 +scopeKey :: Text scopeKey = "scope" -- |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 +ruleDayKey :: Text ruleDayKey = "day" -- |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 +subjectKey :: Text subjectKey = "subject" -- |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 +lessonSlotKey :: Text lessonSlotKey = "slot" -- |How many days a week has +daysPerWeek :: Int daysPerWeek = 7 -- |The amount of imeslots each day +slotsPerDay :: Int slotsPerDay = 7 -- |The caracter width of a single slot in output +cellWidth :: Int cellWidth = 20 --- |Open a file and return the contents as parsed json -getFromFile :: JSON a => String -> IO(Result a) -getFromFile filename = liftM decodeStrict (readFile filename) +-- |Base structure of the input JSON file +data DataFile = DataFile [Rule] [Lesson Text] --- |Open a file and write json to it -writeToFile :: String -> JSValue -> IO() -writeToFile filename = writeFile filename . JSON.encode +instance FromJSON a => FromJSON (Lesson a) where + parseJSON (Object o) = Lesson + <$> o .: lessonSlotKey + <*> o .: lessonDayKey + <*> pure 0 + <*> o .: subjectKey + parseJSON _ = mzero --- | parses file as JSON and returns internally used data structures --- | convenience function -deSerialize :: String -> Result ([Result Rule], [Result (Lesson String)]) -deSerialize = transformTypes . decodeStrict +instance ToJSON a => ToJSON (Lesson a) where + toJSON = + object . sequenceA + [ (.=) lessonSlotKey . timeslot + , (.=) lessonDayKey . day + , (.=) subjectKey . subject + ] --- |Turns parsed json values into the internally used datastructures. -transformTypes :: Result JSValue -> Result ([Result Rule], [Result (Lesson String)]) -transformTypes (Ok (JSObject o)) = do - rv <- valFromObj ruleKey o - lv <- valFromObj lessonKey o +instance ToJSON Rule where + toJSON = + object . ((:) + <$> ((.=) severityKey . severity) + <*> 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]) - rules <- extractRules rv - lessons <- extractLessons lv - return (rules, lessons) -transformTypes (Ok _) = Error "wrong value type" -transformTypes (Error e) = Error e +instance FromJSON Rule where + parseJSON (Object o) = Rule + <$> ((o .: scopeKey) >>= fromScope o) + <*> 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 .: ruleSlotKey <*> obj .: ruleDayKey + fromScope _ _ = error "unknown input" -- I am so sorry + parseJSON _ = mzero -serialize :: Show s => [MappedSchedule s] -> String -serialize = JSON.encode . nativeToJson - +instance FromJSON DataFile where + parseJSON (Object o) = DataFile + <$> o .: ruleKey + <*> o .: lessonKey + parseJSON _ = mzero --- |Transform Native the native schedules into JSON -nativeToJson :: Show s => [MappedSchedule s] -> JSValue -nativeToJson = JSArray . map convert - where - convert :: Show s => MappedSchedule s -> JSValue - convert = - pure (\a b -> JSObject (JSON.toJSObject [a,b])) - <*> ((,) "weight" . showJSON . totalWeight) - <*> ((,) "values" . JSArray . - map - (\((i, j), b) -> - JSObject (JSON.toJSObject [ - ("day", showJSON i), - ("slot", showJSON j), - ("subject", (showJSON . show . subject) b) - ])) - . Map.assocs - ) +instance ToJSON DataFile where + toJSON (DataFile r l) = + object + [ lessonKey .= l + , ruleKey .= r + ] --- |Turns a parsed json value into a 'List' of 'Rule's or return an 'Error' -extractRules :: JSValue -> Result [Result Rule] -extractRules (JSArray rv) = return $ map handleOne rv - where - handleOne :: JSValue -> Result Rule - handleOne (JSObject o) = do - scope <- valFromObj scopeKey o - severity <- valFromObj severityKey o - - let rp = (`Rule` severity) - - case scope of - "day" -> do - day <- valFromObj ruleDayKey o - return $ rp $ Day day - "slot" -> do - slot <- valFromObj ruleSlotKey o - return $ rp $ Slot slot - "cell" -> do - slot <- valFromObj ruleSlotKey o - day <- valFromObj ruleDayKey o - return $ rp $ Cell day slot - - handleOne _ = Error "wrong value type" +-- |Convert a suitable Map to a JSON Value +mapToJSON :: ToJSON a => Map.Map Text a -> Value +mapToJSON = object . map (uncurry (.=)) . Map.toList -extractRules _ = Error "key lessons does not contain array" +-- |Open a file and return the contents as parsed json +getFromFile :: FilePath -> IO(Maybe DataFile) +getFromFile = fmap decode . LBS.readFile --- |Turns a parsed json value into a 'List' of 'Lesson's or return an 'Error' -extractLessons :: JSValue -> Result [Result (Lesson String)] -extractLessons (JSArray a) = return $ map handleOne a - where - handleOne :: JSValue -> Result (Lesson String) - handleOne (JSObject o) = do - subject <- valFromObj subjectKey o - day <- valFromObj lessonDayKey o - slot <- valFromObj lessonSlotKey o - return $ Lesson slot day 0 subject - handleOne _ = Error "wrong type" - -extractLessons _ = Error "wrong value type" +-- |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 {-| Transform a 'MappedSchedule' into a printable, - and more importantly, readable String + and more importantly, readable Text -} -formatSchedule :: Show s => MappedSchedule s -> String -formatSchedule hours = intercalate "\n" $ header : map formatDay allHours +formatSchedule :: Show s => MappedSchedule s -> Text +formatSchedule hours = pack $ List.intercalate "\n" $ header : map formatDay allHours where allHours = [(i, [1..slotsPerDay]) | i <- [1..daysPerWeek]] @@ -167,6 +170,6 @@ printf ("%" ++ show cellWidth ++ "v") $ maybe [] (shortSubject . subject) (Map.lookup i hours) formatDay :: (Int, [Int]) -> String - formatDay (i, l) = intercalate " | " [formatLesson (j, i) | j <- l] + formatDay (i, l) = List.intercalate " | " [formatLesson (j, i) | j <- l] header = printf "Total Weight: %10v" (totalWeight hours) diff --git a/src/SchedulePlanner/Server.hs b/src/SchedulePlanner/Server.hs --- a/src/SchedulePlanner/Server.hs +++ b/src/SchedulePlanner/Server.hs @@ -1,12 +1,29 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} -module SchedulePlanner.Server where +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-| +Module : $Header$ +Description : functions necessary for deploying the application as a webservice +Copyright : (c) Justus Adam, 2015 +License : LGPL-3 +Maintainer : development@justusadam.com +Stability : experimental +Portability : POSIX -import Control.Applicative ((<$>), optional) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Data.Text.Lazy (unpack) -import Happstack.Lite -import Text.Blaze.Html5 (Html, (!), a, form, input, p, toHtml, label) -import Text.Blaze.Html5.Attributes (action, enctype, href, name, size, type_, value) -import qualified Text.Blaze.Html5 as H -import qualified Text.Blaze.Html5.Attributes as A +Uses happstack and blaze to create a deployable service instance of this software. +-} +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) + + +app :: (ByteString -> ByteString) -> Application +app a request respond = do + body <- lazyRequestBody request + respond $ responseLBS status200 [] $ a body + +server :: Int -> (ByteString -> ByteString) -> IO () +server port = run port . app