1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
{-# LANGUAGE TypeOperators, DataKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
-- | A specification of an API for interacting with a set of printers
module Thermoprint.API
( PrinterStatus(..)
, JobStatus(..), queueSort
, PrintingError(..), EncodingException(..)
, DraftTitle
, Range(..), contains
, ThermoprintAPI
, thermoprintAPI
, module Thermoprint.Identifiers
, module Thermoprint.Printout
) where
import Thermoprint.Printout
import Thermoprint.Identifiers
import Servant.API
import Data.Aeson
import Data.Monoid
import Data.Maybe
import Data.Function (on)
import Data.Set (Set)
import Data.Map (Map)
import qualified Data.Map as Map (foldMapWithKey, singleton)
import Data.Sequence (Seq)
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap (foldMapWithKey, singleton)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Control.DeepSeq (NFData)
import Data.Proxy (Proxy(..))
import Control.Exception (Exception)
import Data.Time (UTCTime)
import Data.Time.Format
import Data.Encoding.Exception (EncodingException(..))
import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary(..))
import Test.QuickCheck.Gen (scale, variant, oneof)
import Test.QuickCheck.Instances
-- instance (Integral k, Ord k, ToJSON v) => ToJSON (Map k v) where
-- toJSON = toJSON . Map.foldMapWithKey (IntMap.singleton . castId)
-- 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)
data JobStatus = Queued PrinterId
| Printing PrinterId
| Done
| Failed PrintingError
deriving (Generic, Show, FromJSON, ToJSON)
queueSort :: JobStatus -> JobStatus -> Ordering
-- ^ Sort 'JobStatus' by their qualitative position in a printers queue
queueSort = compare `on` index
where
index (Queued _) = -1
index (Printing _) = 0
index Done = 1
index (Failed _) = 1
deriving instance Generic EncodingException
deriving instance NFData EncodingException
deriving instance FromJSON EncodingException
deriving instance ToJSON EncodingException
data PrintingError = IOError String -- ^ Not the actual error because we can't marshal that to JSON
| EncError EncodingException -- ^ Could not encode some part of the 'Printout'
deriving (Typeable, Generic, NFData, Show, FromJSON, ToJSON)
instance Arbitrary PrintingError where
arbitrary = IOError <$> arbitrary
instance CoArbitrary PrintingError where
coarbitrary (IOError _) = variant 0
coarbitrary (EncError _) = variant 1
instance Exception PrintingError
type DraftTitle = Text
data Range a = Min a | Max a | Through a a
deriving (Show, Eq, Generic)
instance Arbitrary a => Arbitrary (Range a) where
arbitrary = oneof [ Min <$> arbitrary
, Max <$> arbitrary
, Through <$> arbitrary <*> arbitrary
]
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 ToHttpApiData a => ToHttpApiData (Range a) where
toUrlPiece (Min min) = toUrlPiece min <> "-"
toUrlPiece (Max max) = "-" <> toUrlPiece max
toUrlPiece (Through min max) = toUrlPiece min <> "-" <> toUrlPiece max
instance FromHttpApiData a => FromHttpApiData (Range a) where
parseUrlPiece t = listToEither $ through <> max <> min
where
through = [ Through min max | ((parseUrlPiece -> Right min), (T.uncons -> Just ('-', (parseUrlPiece -> Right max)))) <- zip (T.inits t) (T.tails t) ]
min = [ Min min | (parseUrlPiece -> Right min) <- T.inits t ]
max = [ Max max | (parseUrlPiece -> Right max) <- T.tails t ]
listToEither [x] = Right x
listToEither _ = Left t
type ThermoprintAPI = "printers" :> Get '[JSON] (Map PrinterId PrinterStatus)
:<|> "jobs" :> (
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
)
:<|> "job" :> Capture "jobId" JobId :> (
Get '[JSON] Printout
:<|> "status" :> Get '[JSON] JobStatus
:<|> Delete '[JSON] ()
)
:<|> "drafts" :> (
Get '[JSON] (Map DraftId (Maybe DraftTitle))
:<|> QueryParam "title" DraftTitle :> ReqBody '[JSON] Printout :> Post '[JSON] DraftId
)
:<|> "draft" :> Capture "draftId" DraftId :> (
QueryParam "title" DraftTitle :> ReqBody '[JSON] Printout :> Put '[JSON] ()
:<|> Get '[JSON] (Maybe DraftTitle, Printout)
:<|> Delete '[JSON] ()
:<|> QueryParam "printer" PrinterId :> Post '[JSON] JobId
)
thermoprintAPI :: Proxy ThermoprintAPI
-- ^ Servant occasionally needs an object of this type
thermoprintAPI = Proxy
|
