aboutsummaryrefslogtreecommitdiff
path: root/server/src
diff options
context:
space:
mode:
authorGregor Kleen <gkleen@yggdrasil.li>2016-02-04 19:04:35 +0000
committerGregor Kleen <gkleen@yggdrasil.li>2016-02-04 19:04:35 +0000
commitc63f7ca27bf3a014dd501a6f58dc6a983251df4d (patch)
tree9c0abc87a330f226519de8e122005007c633a021 /server/src
parenta7e923cba4dea3d5e0aaf03081d8d3266681c8d5 (diff)
downloadthermoprint-c63f7ca27bf3a014dd501a6f58dc6a983251df4d.tar
thermoprint-c63f7ca27bf3a014dd501a6f58dc6a983251df4d.tar.gz
thermoprint-c63f7ca27bf3a014dd501a6f58dc6a983251df4d.tar.bz2
thermoprint-c63f7ca27bf3a014dd501a6f58dc6a983251df4d.tar.xz
thermoprint-c63f7ca27bf3a014dd501a6f58dc6a983251df4d.zip
Split Queue-management into new module
Diffstat (limited to 'server/src')
-rw-r--r--server/src/Thermoprint/Server/API.hs1
-rw-r--r--server/src/Thermoprint/Server/Printer.hs24
-rw-r--r--server/src/Thermoprint/Server/Queue.hs43
3 files changed, 46 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(..))
13import qualified Thermoprint.API as API (JobId(..), DraftId(..)) 13import qualified Thermoprint.API as API (JobId(..), DraftId(..))
14 14
15import Thermoprint.Server.Printer 15import Thermoprint.Server.Printer
16import Thermoprint.Server.Queue
16import Thermoprint.Server.Database 17import Thermoprint.Server.Database
17 18
18import Data.Set (Set) 19import 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
11module Thermoprint.Server.Printer 10module Thermoprint.Server.Printer
12 ( PrinterMethod(..), Printer(..) 11 ( PrinterMethod(..), Printer(..)
@@ -48,6 +47,8 @@ import Control.Concurrent.STM
48 47
49import Data.Time.Clock 48import Data.Time.Clock
50 49
50import Thermoprint.Server.Queue
51
51newtype PrinterMethod = PM { unPM :: forall m. (MonadResource m, MonadLogger m) => Printout -> m (Maybe PrintingError) } 52newtype PrinterMethod = PM { unPM :: forall m. (MonadResource m, MonadLogger m) => Printout -> m (Maybe PrintingError) }
52 53
53data Printer = Printer 54data 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'
59data 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
66instance Default Queue where
67 def = Queue
68 { pending = Seq.empty
69 , current = Nothing
70 , history = Seq.empty
71 }
72
73data QueueEntry = QueueEntry
74 { jobId :: JobId
75 , created :: UTCTime
76 }
77 deriving (Typeable, Generic, NFData)
78
79printer :: MonadResource m => m PrinterMethod -> m Printer 59printer :: MonadResource m => m PrinterMethod -> m Printer
80printer p = Printer <$> p <*> liftIO (newTVarIO def) 60printer 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
3module Thermoprint.Server.Queue
4 ( Queue(..), QueueEntry(..)
5 ) where
6
7import Thermoprint.API (PrintingError(..), Printout)
8import qualified Thermoprint.API as API (JobStatus(..))
9
10import Thermoprint.Server.Database
11
12import Data.Sequence (Seq)
13import qualified Data.Sequence as Seq
14
15import Data.Time
16
17import Control.DeepSeq (NFData)
18import Data.Typeable (Typeable)
19import GHC.Generics (Generic)
20
21import Data.Default.Class
22
23-- | Zipper for 'Seq QueueEntry'
24data 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
31instance Default Queue where
32 def = Queue
33 { pending = Seq.empty
34 , current = Nothing
35 , history = Seq.empty
36 }
37
38data QueueEntry = QueueEntry
39 { jobId :: JobId
40 , created :: UTCTime
41 }
42 deriving (Typeable, Generic, NFData)
43