summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGregor Kleen <gkleen@yggdrasil.li>2016-01-11 18:14:51 +0100
committerGregor Kleen <gkleen@yggdrasil.li>2016-01-11 18:14:51 +0100
commit49dad7900ed4ceb1c5a7d3b30632af3575baa1b0 (patch)
tree62de1d388049df79ebe9359178b992d5697c180f
parentdfd40fb9d60f7531e8341dc6d927ec1dd5a85cff (diff)
parent99b75b1c17058661db5bc15a0aa7b61d361a6552 (diff)
downloaddirty-haskell.org-49dad7900ed4ceb1c5a7d3b30632af3575baa1b0.tar
dirty-haskell.org-49dad7900ed4ceb1c5a7d3b30632af3575baa1b0.tar.gz
dirty-haskell.org-49dad7900ed4ceb1c5a7d3b30632af3575baa1b0.tar.bz2
dirty-haskell.org-49dad7900ed4ceb1c5a7d3b30632af3575baa1b0.tar.xz
dirty-haskell.org-49dad7900ed4ceb1c5a7d3b30632af3575baa1b0.zip
Merge branch 'master' of git.yggdrasil.li:dirty-haskell.org
Diffstat
-rw-r--r--provider/posts/thermoprint-2.lhs262
-rw-r--r--provider/posts/thermoprint-3.lhs92
2 files changed, 354 insertions, 0 deletions
diff --git a/provider/posts/thermoprint-2.lhs b/provider/posts/thermoprint-2.lhs
new file mode 100644
index 0000000..056f1ef
--- /dev/null
+++ b/provider/posts/thermoprint-2.lhs
@@ -0,0 +1,262 @@
1---
2title: On the design of a structured document format compatible with character oriented printers
3published: 2016-01-11
4tags: Thermoprint
5---
6
7This post is an annotated version of the file `spec/src/Thermoprint/Printout.hs` as of commit [f6dc3d1](git://git.yggdrasil.li/thermoprint#f6dc3d1).
8
9> {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
10> {-# LANGUAGE OverloadedStrings #-}
11> {-# OPTIONS_HADDOCK show-extensions #-}
12
13Motivation
14----------
15
16We want our codebase to be compatible with as many different models of printers as we are willing to implement.
17It is therefore desirable to maintain a structured document format which we can transform into a printer-specific representation of the payload to be printed with minimal effort.
18
19In this post we present one such format.
20
21Contents
22--------
23
24> -- | This module contains the definition of the structure -- 'Printout' -- used to represent the content of a job
25> module Thermoprint.Printout
26> ( Printout(..)
27> , Paragraph(..)
28> , Chunk(..)
29> , Block(..)
30> , Line( HSpace
31> , SpaceSep
32> )
33> , text, cotext
34> , prop_text
35> ) where
36
37Preliminaries
38-------------
39
40> import Data.Sequence (Seq, (|>), (<|))
41
42A Sequence represents the same structure as the linked lists common in haskell but supports $O(1)$ `snoc`, which is desirable since we intend to iteratively build up the structure when parsing input formats.
43
44> import Data.Text.Lazy (Text)
45>
46> import Data.ByteString.Lazy (ByteString)
47
48The entire structure will be lazy by default but an instance of `NFData`, thus the lazy variants of `Text` and `ByteString`.
49
50> import GHC.Generics (Generic)
51
52We will use derived instances of `Generic` to get handed suitable instances of rather complicated classes such as `Arbitrary` and `FromJSON`
53
54> import Control.DeepSeq (NFData)
55
56Instances of `NFData` allow us to strictly evaluate our document structure when needed
57
58> import Data.Aeson (FromJSON(..), ToJSON(..), Value(..))
59> import qualified Data.Aeson as JSON (encode, decode)
60> import Data.Aeson.Types (typeMismatch)
61
62We will encode the document as a [json](https://en.wikipedia.org/wiki/JSON) object during transport
63
64> import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary, genericShrink)
65> import Test.QuickCheck.Modifiers (NonNegative(..))
66> import Test.QuickCheck.Gen (oneof, suchThat, scale)
67> import Test.QuickCheck.Instances
68> import Test.QuickCheck (forAll, Property)
69
70We will use [QuickCheck](https://hackage.haskell.org/package/QuickCheck) for automatic test generation.
71
72> import qualified Data.Text.Lazy as TL (split, null, pack, filter, intercalate, map)
73> import qualified Data.Text as T (pack)
74> import Data.Char (isSpace)
75>
76> import Data.Monoid (Monoid(..), (<>))
77>
78> import Data.List (dropWhile, dropWhileEnd, groupBy, genericLength, genericReplicate)
79>
80> import Data.Sequence as Seq (fromList, null, singleton)
81>
82> import Data.Function (on)
83>
84> import Data.Foldable (toList, fold)
85
86We will need to do some parsing and pretty-printing to implement `text` and `cotext`, respectively.
87
88> import Data.Encoding (encodeLazyByteStringExplicit, decodeLazyByteString)
89> import Data.Encoding.UTF8
90> import qualified Data.ByteString.Base64.Lazy as Base64 (encode, decode)
91
92Since we want end users to be able to include direct instructions the printer in the form of a lazy [`ByteString`](https://hackage.haskell.org/package/bytestring) we need some way to encode `ByteString`s in JSON.
93We chose [base64](https://hackage.haskell.org/package/base64-bytestring).
94
95> import Prelude hiding (fold)
96>
97>
98> -- | A 'Printout' is a sequence of visually seperated 'Paragraph's
99> type Printout = Seq Paragraph
100
101"visually seperated" will most likely end up meaning "seperated by a single blank line"
102
103> -- | A 'Paragraph' is a non-seperated sequence of 'Chunk's
104> type Paragraph = Seq Chunk
105>
106> -- | We introduce both 'Chunk' and 'Paragraph' mainly to allow 'Raw'.
107> --
108> -- Were we to disallow 'Raw', 'Block' would be identical to 'Paragraph'
109> data Chunk = Cooked Block -- ^ text semantically structured to be rendered in accordance with the display format of printer
110> | Raw ByteString -- ^ direct instructions to the printer
111> deriving (Generic, NFData, Show, CoArbitrary)
112>
113> instance FromJSON Chunk where
114> parseJSON s@(String _) = Raw <$> ((either fail return . decodeBase64) =<< parseJSON s)
115> where
116> decodeBase64 :: String -> Either String ByteString
117> decodeBase64 s = (either (Left . show) Right . encodeLazyByteStringExplicit UTF8Strict $ s) >>= Base64.decode
118> parseJSON o@(Object _) = Cooked <$> parseJSON o
119> parseJSON v = typeMismatch "Chunk" v
120>
121> instance ToJSON Chunk where
122> toJSON (Raw bs) = String . T.pack . decodeLazyByteString UTF8Strict . Base64.encode $ bs
123> toJSON (Cooked block) = toJSON block
124
125We provide custom instances of `FromJSON Chunk` and `ToJSON Chunk` so that we might reduce the sice of the resulting JSON somewhat (this is an opportune target since disambiguaty is simple)
126
127> -- | 'Block' is the entry point for our structured document format
128> data Block = Line Line -- ^ a single 'Line' of text
129> | VSpace Integer -- ^ vertical space of height equivalent to 'Integer' lines
130> | NewlSep (Seq Block) -- ^ A sequence of 'Block's seperated by newlines
131> deriving (Generic, NFData, Show, CoArbitrary, FromJSON, ToJSON)
132>
133> {- | A 'Line' is one of:
134>
135> * a single word
136> * horizontal space equivalent to the width of 'Integer' `em`.
137> * a sequence of words seperated by spaces
138>
139> We don't export all constructors and instead encourage the use of 'text'.
140> -}
141> data Line = Word Text
142> | HSpace Integer
143> | SpaceSep (Seq Line)
144> deriving (Generic, NFData, Show, CoArbitrary, FromJSON, ToJSON)
145>
146> instance Monoid Block where
147> mempty = NewlSep mempty
148> x@(NewlSep xs) `mappend` y@(NewlSep ys)
149> | Seq.null xs = y
150> | Seq.null ys = x
151> | otherwise = NewlSep (xs <> ys)
152> (NewlSep xs) `mappend` y
153> | Seq.null xs = y
154> | otherwise = NewlSep (xs |> y)
155> x `mappend` (NewlSep ys)
156> | Seq.null ys = x
157> | otherwise = NewlSep (x <| ys)
158> x `mappend` y = NewlSep $ Seq.fromList [x, y]
159>
160> instance Monoid Line where
161> mempty = SpaceSep mempty
162> x@(SpaceSep xs) `mappend` y@(SpaceSep ys)
163> | Seq.null xs = y
164> | Seq.null ys = x
165> | otherwise = SpaceSep (xs <> ys)
166> (SpaceSep xs) `mappend` y
167> | Seq.null xs = y
168> | otherwise = SpaceSep (xs |> y)
169> x `mappend` (SpaceSep ys)
170> | Seq.null ys = x
171> | otherwise = SpaceSep (x <| ys)
172> x `mappend` y = SpaceSep $ Seq.fromList [x, y]
173
174The Monoid instances for `Block` and `Line` are somewhat unwieldy since we want to guarantee minimum overhead by reducing expressions such as `SpaceSep (fromList [x])` to `x` whenever possible.
175
176The same effect would have been possible by introducing the monoid structure *one level higher* -- we could have introduced constructors such as `Line :: Seq Word -> Block`.
177This was deemed undesirable since we would not have been able to implement instances such as `Monoid Line` which allow the use of more generic functions during parsing.
178
179> text :: Text -> Either Block Line
180> -- ^ Smart constructor for 'Line'/'Block' which maps word and line boundaries (as determined by 'isSpace' and '(== '\n')' respectively) to the structure of 'Block' and 'Line'.
181> --
182> -- Since we are unwilling to duplicate the list of chars from 'isSpace' we cannot reasonably determine a width for the various whitespace 'Char's.
183> -- Thus they are all weighted equally as having width 1 `em`.
184> text t = case splitLines t of
185> [] -> Right mempty
186> [Line x] -> Right x
187> xs -> Left $ mconcat xs
188> where
189> splitLines :: Text -> [Block]
190> splitLines t = map toBlock
191> . groupBy ((==) `on` TL.null)
192> $ TL.split (== '\n') t
193> splitWords :: Text -> [Line]
194> splitWords t = map toLine
195> . groupBy ((==) `on` TL.null)
196> $ TL.split isSpace t
197> toBlock [] = mempty
198> toBlock xs@(x:_)
199> | TL.null x = VSpace $ genericLength xs - 1
200> | otherwise = mconcat . map (Line . mconcat . splitWords) $ xs
201> toLine [] = mempty
202> toLine xs@(x:_)
203> | TL.null x = HSpace $ genericLength xs - 1
204> | otherwise = mconcat . map Word $ xs
205> list :: b -> (a -> [a] -> b) -> [a] -> b
206> list c _ [] = c
207> list _ f (x:xs) = f x xs
208
209Implementations using `TL.lines` and `TL.words` were tested.
210We chose to use `TL.split`-based solutions instead because the more specific splitting functions provided by [text](https://hackage.haskell.org/package/text) drop information concerning the exact amount of whitespace.
211
212> cotext :: Block -> Text
213> -- ^ inverse of
214> -- @
215> -- either id Line . `text`
216> -- @
217> cotext (VSpace n) = TL.pack . genericReplicate n $ '\n'
218> cotext (NewlSep xs) = TL.intercalate "\n" . map cotext . toList $ xs
219> cotext (Line x) = cotext' x
220> where
221> cotext' (Word x) = x
222> cotext' (HSpace n) = TL.pack . genericReplicate n $ ' '
223> cotext' (SpaceSep xs) = TL.intercalate " " . map cotext' . toList $ xs
224
225We provide cotext for testing `text` and to enable determining semantic equality of `Printout`s at a later date
226
227> prop_text :: Text -> Bool
228> -- ^ prop> (`cotext` . either id Line . `text` $ x) == x
229> --
230> -- Where 'x' is restricted to those `TL.Text` which do not contain whitespace besides ' ' and '\n'.
231> prop_text x = (cotext . either id Line . text $ x') == x'
232> where
233> x' = TL.map normSpace x
234> normSpace c
235> | isSpace c
236> , c `elem` keep = c
237> | isSpace c = ' ' -- We have to do this because all whitespace gets interpreted as width 1
238> | otherwise = c
239> keep = [' ', '\n']
240>
241> -- | We don't test 'Raw' 'Chunk's
242> instance Arbitrary Chunk where
243> shrink = genericShrink
244> arbitrary = Cooked <$> arbitrary
245>
246> instance Arbitrary Block where
247> shrink = genericShrink
248> arbitrary = oneof [ Line <$> arbitrary
249> , VSpace . getNonNegative <$> arbitrary
250> , NewlSep <$> scale' arbitrary
251> ]
252>
253> instance Arbitrary Line where
254> shrink = genericShrink
255> arbitrary = oneof [ Word . TL.filter (not . isSpace) <$> arbitrary -- 'isSpace '\n' == True'
256> , HSpace . getNonNegative <$> arbitrary
257> , SpaceSep <$> scale' arbitrary
258> ]
259>
260> scale' = scale (round . sqrt . fromInteger . toInteger)
261
262Failing to properly scale the tested structures was shown to use more than 8GiB of RAM during testing
diff --git a/provider/posts/thermoprint-3.lhs b/provider/posts/thermoprint-3.lhs
new file mode 100644
index 0000000..9227c97
--- /dev/null
+++ b/provider/posts/thermoprint-3.lhs
@@ -0,0 +1,92 @@
1---
2title: Thoughts on a network protocol for a toolset for interacting with character-oriented printers
3published: 2016-01-11
4tags: Thermoprint
5---
6
7This post is an annotated version of the file `spec/src/Thermoprint/API.hs` as of commit [3ad700c](git://git.yggdrasil.li/thermoprint#3ad700c).
8
9> {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
10> {-# LANGUAGE TypeOperators, DataKinds #-}
11> {-# LANGUAGE OverloadedStrings #-}
12>
13> module Thermoprint.API
14> ( PrinterStatus(..)
15> , JobStatus(..)
16> , ThermoprintAPI
17> , thermoprintAPI
18> , module Thermoprint.Identifiers
19> , module Thermoprint.Printout
20> ) where
21>
22> import Thermoprint.Printout
23
24See [a previous post](https://dirty-haskell.org/posts/thermoprint-2.html).
25
26> import Thermoprint.Identifiers
27
28`Thermoprint.Identifiers` provides some newtypes of `Integer` to add some typesafety to dealing with objects identified by autoincremented numbers
29
30> import Servant.API
31> import Servant.Docs
32> import Data.Aeson
33
34We will define our API to be compatible with [servant](https://hackage.haskell.org/package/servant)
35
36> import Data.Set (Set)
37> import Data.Sequence (Seq)
38
39Higher performance versions of lists for our various applications
40
41> import GHC.Generics (Generic)
42>
43> import Data.Proxy (Proxy(..))
44>
45> import Control.Exception (Exception)
46> import Data.Typeable (Typeable)
47>
48> data PrinterStatus = Busy JobId
49> | Available
50> deriving (Generic, Show, FromJSON, ToJSON)
51>
52> data JobStatus = Queued
53> | Printing
54> | Done
55> | Failed PrintingError
56> deriving (Generic, Show, FromJSON, ToJSON)
57>
58> data PrintingError = UnknownError
59> deriving (Typeable, Generic, Show, FromJSON, ToJSON, Exception)
60
61We expect the definiton of `PrintingError` to grow considerably while implementing a server for this API
62
63We support the following actions through our API:
64
65> type ThermoprintAPI = "printers" :> Get '[JSON] (Set PrinterId) -- List the identifiers of all available printers (/printers)
66> :<|> "printer" :> Capture "printerId" PrinterId :> (
67> ReqBody '[JSON] Printout :> Post '[JSON] JobId -- Add a new job to the bottom of the queue by sending its content (/printer:printerId)
68> :<|> "status" :> Get '[JSON] PrinterStatus -- Query the current status of a printer (/printer:printerId/status)
69> )
70> :<|> "jobs" :> (
71> QueryParam "printer" PrinterId :> QueryParam "min" JobId :> QueryParam "max" JobId :> Get '[JSON] (Seq JobId) -- List all jobs allowing for selection by printerId and pagination (/jobs?printer=*&min=*&max=*)
72> )
73> :<|> "job" :> Capture "jobId" JobId :> (
74> Get '[JSON] Printout -- Get the contents of a job currently known to the server (/job:jobId)
75> :<|> "status" :> Get '[JSON] JobStatus -- Get the status of a job (/job:jobId/status)
76> :<|> "printer" :> Get '[JSON] PrinterId -- Find the printer a job was queued for (/job:jobId/printer)
77> :<|> Delete '[] () -- Abort a job (which we expect to make it unknown to the server) (/job:jobId)
78> )
79> :<|> "drafts" :> (
80> Get '[JSON] (Set DraftId) -- List the identifiers of all drafts known to the server (/drafts)
81> :<|> ReqBody '[JSON] Printout :> Post '[JSON] DraftId -- Make a draft known to the server by submitting its contents (/drafts)
82> )
83> :<|> "draft" :> Capture "draftId" DraftId :> (
84> ReqBody '[JSON] Printout :> Put '[] () -- Update a draft by replacing its contents (/draft:draftId)
85> :<|> Get '[JSON] Printout -- Get the contents of a draft (/draft:draftId)
86> :<|> Delete '[] () -- Delete a draft (/draft:draftId)
87> )
88>
89> thermoprintAPI :: Proxy ThermoprintAPI
90> thermoprintAPI = Proxy
91
92servant needs an object of type `Proxy ThermoprintAPI` in various places
generated by cgit v1.2.3 (git 2.25.1) at 2024-04-27 09:50:41 +0000