diff options
Diffstat (limited to 'server')
-rw-r--r-- | server/src/Thermoprint/Server/API.hs | 1 | ||||
-rw-r--r-- | server/src/Thermoprint/Server/Printer.hs | 24 | ||||
-rw-r--r-- | server/src/Thermoprint/Server/Queue.hs | 43 | ||||
-rw-r--r-- | server/thermoprint-server.cabal | 1 |
4 files changed, 47 insertions, 22 deletions
diff --git a/server/src/Thermoprint/Server/API.hs b/server/src/Thermoprint/Server/API.hs index 247fb89..7868f2c 100644 --- a/server/src/Thermoprint/Server/API.hs +++ b/server/src/Thermoprint/Server/API.hs | |||
@@ -13,6 +13,7 @@ import Thermoprint.API hiding (JobId(..), DraftId(..)) | |||
13 | import qualified Thermoprint.API as API (JobId(..), DraftId(..)) | 13 | import qualified Thermoprint.API as API (JobId(..), DraftId(..)) |
14 | 14 | ||
15 | import Thermoprint.Server.Printer | 15 | import Thermoprint.Server.Printer |
16 | import Thermoprint.Server.Queue | ||
16 | import Thermoprint.Server.Database | 17 | import Thermoprint.Server.Database |
17 | 18 | ||
18 | import Data.Set (Set) | 19 | import Data.Set (Set) |
diff --git a/server/src/Thermoprint/Server/Printer.hs b/server/src/Thermoprint/Server/Printer.hs index 5dc593e..3700f45 100644 --- a/server/src/Thermoprint/Server/Printer.hs +++ b/server/src/Thermoprint/Server/Printer.hs | |||
@@ -6,7 +6,6 @@ | |||
6 | {-# LANGUAGE StandaloneDeriving #-} | 6 | {-# LANGUAGE StandaloneDeriving #-} |
7 | {-# LANGUAGE GADTs #-} | 7 | {-# LANGUAGE GADTs #-} |
8 | {-# LANGUAGE ExistentialQuantification #-} | 8 | {-# LANGUAGE ExistentialQuantification #-} |
9 | {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} | ||
10 | 9 | ||
11 | module Thermoprint.Server.Printer | 10 | module Thermoprint.Server.Printer |
12 | ( PrinterMethod(..), Printer(..) | 11 | ( PrinterMethod(..), Printer(..) |
@@ -48,6 +47,8 @@ import Control.Concurrent.STM | |||
48 | 47 | ||
49 | import Data.Time.Clock | 48 | import Data.Time.Clock |
50 | 49 | ||
50 | import Thermoprint.Server.Queue | ||
51 | |||
51 | newtype PrinterMethod = PM { unPM :: forall m. (MonadResource m, MonadLogger m) => Printout -> m (Maybe PrintingError) } | 52 | newtype PrinterMethod = PM { unPM :: forall m. (MonadResource m, MonadLogger m) => Printout -> m (Maybe PrintingError) } |
52 | 53 | ||
53 | data Printer = Printer | 54 | data Printer = Printer |
@@ -55,27 +56,6 @@ data Printer = Printer | |||
55 | , queue :: TVar Queue | 56 | , queue :: TVar Queue |
56 | } | 57 | } |
57 | 58 | ||
58 | -- | Zipper for 'Seq QueueEntry' | ||
59 | data Queue = Queue | ||
60 | { pending :: Seq QueueEntry -- ^ Pending jobs, closest last | ||
61 | , current :: Maybe QueueEntry | ||
62 | , history :: Seq (QueueEntry, Maybe PrintingError) -- ^ Completed jobs, closest first | ||
63 | } | ||
64 | deriving (Typeable, Generic, NFData) | ||
65 | |||
66 | instance Default Queue where | ||
67 | def = Queue | ||
68 | { pending = Seq.empty | ||
69 | , current = Nothing | ||
70 | , history = Seq.empty | ||
71 | } | ||
72 | |||
73 | data QueueEntry = QueueEntry | ||
74 | { jobId :: JobId | ||
75 | , created :: UTCTime | ||
76 | } | ||
77 | deriving (Typeable, Generic, NFData) | ||
78 | |||
79 | printer :: MonadResource m => m PrinterMethod -> m Printer | 59 | printer :: MonadResource m => m PrinterMethod -> m Printer |
80 | printer p = Printer <$> p <*> liftIO (newTVarIO def) | 60 | printer p = Printer <$> p <*> liftIO (newTVarIO def) |
81 | 61 | ||
diff --git a/server/src/Thermoprint/Server/Queue.hs b/server/src/Thermoprint/Server/Queue.hs new file mode 100644 index 0000000..d2400a1 --- /dev/null +++ b/server/src/Thermoprint/Server/Queue.hs | |||
@@ -0,0 +1,43 @@ | |||
1 | {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} | ||
2 | |||
3 | module Thermoprint.Server.Queue | ||
4 | ( Queue(..), QueueEntry(..) | ||
5 | ) where | ||
6 | |||
7 | import Thermoprint.API (PrintingError(..), Printout) | ||
8 | import qualified Thermoprint.API as API (JobStatus(..)) | ||
9 | |||
10 | import Thermoprint.Server.Database | ||
11 | |||
12 | import Data.Sequence (Seq) | ||
13 | import qualified Data.Sequence as Seq | ||
14 | |||
15 | import Data.Time | ||
16 | |||
17 | import Control.DeepSeq (NFData) | ||
18 | import Data.Typeable (Typeable) | ||
19 | import GHC.Generics (Generic) | ||
20 | |||
21 | import Data.Default.Class | ||
22 | |||
23 | -- | Zipper for 'Seq QueueEntry' | ||
24 | data Queue = Queue | ||
25 | { pending :: Seq QueueEntry -- ^ Pending jobs, closest last | ||
26 | , current :: Maybe QueueEntry | ||
27 | , history :: Seq (QueueEntry, Maybe PrintingError) -- ^ Completed jobs, closest first | ||
28 | } | ||
29 | deriving (Typeable, Generic, NFData) | ||
30 | |||
31 | instance Default Queue where | ||
32 | def = Queue | ||
33 | { pending = Seq.empty | ||
34 | , current = Nothing | ||
35 | , history = Seq.empty | ||
36 | } | ||
37 | |||
38 | data QueueEntry = QueueEntry | ||
39 | { jobId :: JobId | ||
40 | , created :: UTCTime | ||
41 | } | ||
42 | deriving (Typeable, Generic, NFData) | ||
43 | |||
diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal index ebe1055..b948ce3 100644 --- a/server/thermoprint-server.cabal +++ b/server/thermoprint-server.cabal | |||
@@ -20,6 +20,7 @@ library | |||
20 | exposed-modules: Thermoprint.Server | 20 | exposed-modules: Thermoprint.Server |
21 | , Thermoprint.Server.Database | 21 | , Thermoprint.Server.Database |
22 | , Thermoprint.Server.API | 22 | , Thermoprint.Server.API |
23 | , Thermoprint.Server.Queue | ||
23 | , Thermoprint.Server.Printer | 24 | , Thermoprint.Server.Printer |
24 | , Thermoprint.Server.Printer.Debug | 25 | , Thermoprint.Server.Printer.Debug |
25 | other-modules: Thermoprint.Server.Database.Instances | 26 | other-modules: Thermoprint.Server.Database.Instances |