From a805783f4bb2868e63ba49a911775fff30df5a07 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 18 Feb 2016 15:04:19 +0100 Subject: Introduced Range --- client/src/Thermoprint/Client.hs | 7 +++---- server/src/Thermoprint/Server/API.hs | 15 ++++++--------- spec/src/Thermoprint/API.hs | 34 ++++++++++++++++++++++++++++------ 3 files changed, 37 insertions(+), 19 deletions(-) diff --git a/client/src/Thermoprint/Client.hs b/client/src/Thermoprint/Client.hs index 80045dd..2b99e7e 100644 --- a/client/src/Thermoprint/Client.hs +++ b/client/src/Thermoprint/Client.hs @@ -45,10 +45,8 @@ data Client m = Client { printers :: EitherT ServantError m (Map PrinterId PrinterStatus) -- ^ List all printers , jobs :: Maybe PrinterId - -> Maybe JobId - -> Maybe JobId - -> Maybe UTCTime - -> Maybe UTCTime + -> Maybe (Range (JobId)) + -> Maybe (Range (UTCTime)) -> EitherT ServantError m (Seq (JobId, UTCTime, JobStatus)) -- ^ @jobs p minId maxId minTime maxTime@ lists a selection of jobs , jobCreate :: Maybe PrinterId -> Printout -> EitherT ServantError m JobId @@ -79,6 +77,7 @@ data Client m = Client } withArgs :: (x -> a :<|> b) -> ((x -> a) :<|> (x -> b)) +-- ^ Undo factoring of APIs withArgs subAPI = (\(a :<|> _) -> a) . subAPI :<|> (\(_ :<|> b) -> b) . subAPI mkClient :: (IO :~> m) -- ^ A monad functor ('Nat') used to make the api functions work in any monad which can be constructed from 'IO' diff --git a/server/src/Thermoprint/Server/API.hs b/server/src/Thermoprint/Server/API.hs index cd4326e..3f3ab46 100644 --- a/server/src/Thermoprint/Server/API.hs +++ b/server/src/Thermoprint/Server/API.hs @@ -141,16 +141,13 @@ printerStatus = fmap queueToStatus . queue' . snd <=< lookupPrinter . Just queueToStatus (Queue _ (Just c) _) = Busy . castId $ jobId c listJobs :: Maybe PrinterId - -> Maybe API.JobId -> Maybe API.JobId - -> Maybe UTCTime -> Maybe UTCTime + -> Maybe (Range API.JobId) -> Maybe (Range UTCTime) -> Handler (Seq (API.JobId, UTCTime, JobStatus)) -listJobs Nothing minId maxId minTime maxTime = fmap mconcat . mapM (\pId -> listJobs (Just pId) minId maxId minTime maxTime) =<< asks (Map.keys . printers) -listJobs pId minId maxId minTime maxTime = fmap (filterJobs . extractJobs) . (\(a, b) -> (,) a <$> queue' b) =<< lookupPrinter pId +listJobs Nothing idR timeR = fmap mconcat . mapM (\pId -> listJobs (Just pId) idR timeR) =<< asks (Map.keys . printers) +listJobs pId idR timeR = fmap (filterJobs . extractJobs) . (\(a, b) -> (,) a <$> queue' b) =<< lookupPrinter pId where - filterJobs = Seq.filter (\(id, time, _) -> and ([ maybe True (<= id ) minId - , maybe True (>= id ) maxId - , maybe True (<= time) minTime - , maybe True (>= time) maxTime + filterJobs = Seq.filter (\(id, time, _) -> and ([ maybe True (`contains` id) idR + , maybe True (`contains` time) timeR ] :: [Bool]) ) @@ -158,7 +155,7 @@ getJob :: API.JobId -> Handler Printout getJob jobId = fmap jobContent . maybe (left err404) return =<< runSqlPool (get $ castId jobId) =<< asks sqlPool jobStatus :: API.JobId -> Handler JobStatus -jobStatus jobId = maybe (left err404) return . lookup jobId . map (\(id, _, st) -> (id, st)) . toList =<< listJobs Nothing Nothing Nothing Nothing Nothing +jobStatus jobId = maybe (left err404) return . lookup jobId . map (\(id, _, st) -> (id, st)) . toList =<< listJobs Nothing Nothing Nothing abortJob :: API.JobId -> Handler () abortJob needle = do diff --git a/spec/src/Thermoprint/API.hs b/spec/src/Thermoprint/API.hs index d854e73..5bfe431 100644 --- a/spec/src/Thermoprint/API.hs +++ b/spec/src/Thermoprint/API.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TypeOperators, DataKinds #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} -- | A specification of an API for interacting with a set of printers module Thermoprint.API @@ -9,6 +10,7 @@ module Thermoprint.API , JobStatus(..) , PrintingError(..) , DraftTitle + , Range(..), contains , ThermoprintAPI , thermoprintAPI , module Thermoprint.Identifiers @@ -21,6 +23,9 @@ import Thermoprint.Identifiers import Servant.API import Data.Aeson +import Data.Monoid +import Data.Maybe + import Data.Set (Set) import Data.Map (Map) import qualified Data.Map as Map (foldMapWithKey, singleton) @@ -51,7 +56,6 @@ instance (Integral k, Ord k, ToJSON v) => ToJSON (Map k v) where instance (Enum k, Ord k, FromJSON v) => FromJSON (Map k v) where parseJSON = fmap (IntMap.foldMapWithKey $ Map.singleton . castId) . parseJSON - data PrinterStatus = Busy JobId | Available deriving (Generic, Show, FromJSON, ToJSON) @@ -81,13 +85,31 @@ instance FromText UTCTime where instance ToText UTCTime where toText = T.pack . formatTime defaultTimeLocale "%F_%T%Q" +data Range a = Min a | Max a | Through a a + +contains :: Ord a => Range a -> a -> Bool +-- ^ Check if a 'Range' contains a point +contains (Min min) x = min <= x +contains (Max max) x = max >= x +contains (Through min max) x = min <= x && x <= max + +instance ToText a => ToText (Range a) where + toText (Min min) = toText min <> "-" + toText (Max max) = "-" <> toText max + toText (Through min max) = toText min <> "-" <> toText max + +instance FromText a => FromText (Range a) where + fromText t = listToMaybe $ through <> max <> min + where + through = [ Through min max | ((fromText -> Just min), (T.uncons -> Just ('-', (fromText -> Just max)))) <- zip (T.inits t) (T.tails t) ] + min = [ Min min | (fromText -> Just min) <- T.inits t ] + max = [ Max max | (fromText -> Just max) <- T.tails t ] + type ThermoprintAPI = "printers" :> Get '[JSON] (Map PrinterId PrinterStatus) :<|> "jobs" :> ( - QueryParam "printer" PrinterId -- TODO: this is silly, introduce data Range a = Range { rMin :: a, rMax :: a } - :> QueryParam "min" JobId - :> QueryParam "max" JobId - :> QueryParam "minTime" UTCTime - :> QueryParam "maxTime" UTCTime + QueryParam "printer" PrinterId + :> QueryParam "jobId" (Range JobId) + :> QueryParam "time" (Range UTCTime) :> Get '[JSON] (Seq (JobId, UTCTime, JobStatus)) :<|> QueryParam "printer" PrinterId :> ReqBody '[JSON] Printout :> Post '[JSON] JobId ) -- cgit v1.2.3