aboutsummaryrefslogtreecommitdiff
path: root/spec/src/Thermoprint/API.hs
blob: 9e914871d7dbb3746552744a95ae88780b9e0088 (plain)
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
159
160
161
162
{-# 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

instance FromText UTCTime where
  fromText = parseTimeM True defaultTimeLocale "%F_%T%Q" . T.unpack

instance ToText UTCTime where
  toText = T.pack . formatTime defaultTimeLocale "%F_%T%Q"

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 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
                          :> 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 '[PlainText] ()
                      )
                      :<|> "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 '[PlainText] ()
                        :<|> Get '[JSON] (Maybe DraftTitle, Printout)
                        :<|> Delete '[PlainText] ()
                        :<|> QueryParam "printer" PrinterId :> Post '[JSON] JobId
                      )

thermoprintAPI :: Proxy ThermoprintAPI
-- ^ Servant occasionally needs an object of this type 
thermoprintAPI = Proxy