schedule-planner 0.1.0.2 → 1.0.0.0
raw patch · 8 files changed
+388/−309 lines, 8 filesdep +aesondep +bytestringdep +http-typesdep −happstack-litedep −jsondep ~containersdep ~mtldep ~options
Dependencies added: aeson, bytestring, http-types, text, wai, warp
Dependencies removed: happstack-lite, json
Dependency ranges changed: containers, mtl, options, transformers
Files
- schedule-planner.cabal +15/−9
- src/Main.hs +95/−51
- src/SchedulePlanner/App.hs +70/−48
- src/SchedulePlanner/Calculator.hs +11/−11
- src/SchedulePlanner/Calculator/Scale.hs +31/−43
- src/SchedulePlanner/Calculator/Solver.hs +42/−43
- src/SchedulePlanner/Serialize.hs +96/−93
- src/SchedulePlanner/Server.hs +28/−11
schedule-planner.cabal view
@@ -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 <development@justusadam.com>-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
src/Main.hs view
@@ -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
src/SchedulePlanner/App.hs view
@@ -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
src/SchedulePlanner/Calculator.hs view
@@ -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
src/SchedulePlanner/Calculator/Scale.hs view
@@ -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 {-|
src/SchedulePlanner/Calculator/Solver.hs view
@@ -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
src/SchedulePlanner/Serialize.hs view
@@ -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)
src/SchedulePlanner/Server.hs view
@@ -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