aboutsummaryrefslogtreecommitdiff
path: root/tprint
diff options
context:
space:
mode:
Diffstat (limited to 'tprint')
-rw-r--r--tprint/src/Instances.hs25
-rw-r--r--tprint/src/Main.hs155
-rw-r--r--tprint/src/Options.hs115
-rw-r--r--tprint/src/Options/Utils.hs48
-rw-r--r--tprint/tprint.cabal6
5 files changed, 201 insertions, 148 deletions
diff --git a/tprint/src/Instances.hs b/tprint/src/Instances.hs
new file mode 100644
index 0000000..cffb8b0
--- /dev/null
+++ b/tprint/src/Instances.hs
@@ -0,0 +1,25 @@
1module Instances where
2
3import Data.Text (Text)
4import qualified Data.Text as T (unpack)
5
6import Data.Time (UTCTime, formatTime, defaultTimeLocale)
7
8import Text.Show.Pretty (Value, PrettyVal(..), dumpStr)
9import qualified Text.Show.Pretty as PShow (Value(..))
10
11import Thermoprint.Client (Scheme(..), BaseUrl(..), PrinterId(..), JobId(..), DraftId(..), Range(..))
12
13instance PrettyVal Scheme
14instance PrettyVal BaseUrl
15instance PrettyVal PrinterId
16instance PrettyVal JobId
17instance PrettyVal DraftId
18instance PrettyVal a => PrettyVal (Range a)
19
20instance PrettyVal UTCTime where
21 prettyVal = PShow.String . formatTime defaultTimeLocale "%Z %F %X"
22
23instance PrettyVal Text where
24 prettyVal = prettyVal . T.unpack
25
diff --git a/tprint/src/Main.hs b/tprint/src/Main.hs
index e8d4670..cd6e68b 100644
--- a/tprint/src/Main.hs
+++ b/tprint/src/Main.hs
@@ -1,6 +1,4 @@
1{-# LANGUAGE RecordWildCards #-} 1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE StandaloneDeriving #-}
3{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
4 2
5import Data.Map (Map) 3import Data.Map (Map)
6import qualified Data.Map as Map 4import qualified Data.Map as Map
@@ -8,157 +6,22 @@ import Data.Sequence (Seq)
8import qualified Data.Sequence as Seq 6import qualified Data.Sequence as Seq
9import Data.Text (Text) 7import Data.Text (Text)
10import qualified Data.Text as T 8import qualified Data.Text as T
11import Data.Time
12
13import Data.Foldable
14import Data.Char
15import Text.Read
16import Data.Maybe
17import Data.List
18 9
19import GHC.Generics (Generic) 10import Control.Monad
20 11
21import Text.Show.Pretty (Value, PrettyVal(..), dumpStr) 12import Text.Show.Pretty (dumpStr)
22import qualified Text.Show.Pretty as PShow (Value(..)) 13
14import System.IO
23 15
24import Thermoprint.Client 16import Thermoprint.Client
25import Options.Applicative 17import Options
26 18
27import Debug.Trace 19import Debug.Trace
28 20
29instance PrettyVal Scheme
30instance PrettyVal BaseUrl
31instance PrettyVal PrinterId
32instance PrettyVal JobId
33instance PrettyVal DraftId
34instance PrettyVal a => PrettyVal (Range a)
35
36instance PrettyVal UTCTime where
37 prettyVal = PShow.String . formatTime defaultTimeLocale "%Z %F %X"
38
39instance PrettyVal Text where
40 prettyVal = prettyVal . T.unpack
41
42data TPrint = TPrint
43 { baseUrl :: BaseUrl
44 , dryRun :: Bool
45 , output :: Output
46 , operation :: Operation
47 }
48 deriving (Show, Generic, PrettyVal)
49
50data Operation
51 = Printers
52 | Jobs
53 { printer :: Maybe PrinterId
54 , jobRange :: Maybe (Range JobId)
55 , timeRange :: Maybe (Range UTCTime)
56 }
57 | JobCreate
58 { printer :: Maybe PrinterId
59 , input :: Input
60 }
61 | Job { jobId :: JobId }
62 | JobStatus { jobId :: JobId }
63 | JobDelete { jobId :: JobId }
64 | Drafts
65 | DraftCreate
66 { draftTitle :: Maybe DraftTitle
67 , input :: Input
68 }
69 | DraftReplace
70 { draftId :: DraftId
71 , draftTitle :: Maybe DraftTitle
72 , input :: Input
73 }
74 | Draft { draftId :: DraftId }
75 | DraftDelete { draftId :: DraftId }
76 | DraftPrint
77 { draftId :: DraftId
78 , printer :: Maybe PrinterId
79 }
80 deriving (Show, Generic, PrettyVal)
81
82type Input = (Format, Source)
83type Output = (Format, Sink )
84
85data Format = Human | BBCode | Internal | JSON
86 deriving (Enum, Bounded, Show, Read, Generic, PrettyVal)
87
88data Source = Stdin | ReadFile FilePath
89 deriving (Show, Generic, PrettyVal)
90
91data Sink = Stdout | WriteFile FilePath
92 deriving (Show, Generic, PrettyVal)
93
94cmdPrinters :: ParserInfo Operation
95cmdPrinters = info cmdPrinters' $ mconcat [ header "List all available printers"
96 ]
97 where cmdPrinters' = pure Printers
98
99cmdJobs :: ParserInfo Operation
100cmdJobs = info cmdJobs' $ mconcat [ header "List printjobs"
101 ]
102 where
103 cmdJobs' = Jobs
104 <$> optional (option (PrinterId <$> auto) $ metavar "PRINTER" <> long "printer" <> short 'p' <> help "List only jobs associated with printer #PRINTER")
105 <*> pRange (JobId <$> auto) (metavar "JOB") (long "min-job" <> short 'j' <> help "List only jobs with id greater than or equal to JOB") (long "max-job" <> short 'J' <> help "List only jobs with id less than or equal to JOB")
106 <*> pRange rTime (metavar "TIME") (long "min-time" <> short 't' <> help "List only jobs created after or at TIME") (long "max-time" <> short 'T' <> help "List only jobs created before or at TIME")
107
108pOperation :: Parser Operation
109pOperation = hsubparser $ mconcat [ command "printers" cmdPrinters
110 , command "jobs" cmdJobs
111 ]
112
113pTPrint :: Parser TPrint
114pTPrint = TPrint <$> option (eitherReader parseBaseUrl) (metavar "URL" <> long "baseurl" <> short 'u' <> help "Server to interact with" <> value (BaseUrl Http "localhost" 3000) <> showDefaultWith showBaseUrl)
115 <*> switch (long "dry-run" <> short 'n' <> help "Don't send any requests that would be expected to change the servers state" <> showDefault)
116 <*> pOutput
117 <*> pOperation
118
119pOutput :: Parser Output
120pOutput = (,) <$> pOutputFormat <*> pSink
121 where
122 pOutputFormat = option ciAuto $ metavar "FORMAT" <> long "output-format" <> short 'O' <> help ("Format to use for all output (possible values: " ++ show ([minBound..maxBound] :: [Format]) ++ ")") <> value Human <> showDefault
123 pSink = option rSink $ metavar "PATH" <> long "output" <> short 'o' <> help "Send output to PATH (`-' means stdout)" <> value Stdout <> showDefault
124 rSink = rSink' <$> str
125 where
126 rSink' "-" = Stdout
127 rSink' x = WriteFile x
128
129ciAuto :: (Read a, Show a) => ReadM a
130ciAuto = eitherReader rRep'
131 where
132 rRep' str = case mapMaybe readMaybe $ cases str of
133 [] -> Left $ "Could not parse `" ++ str ++ "'"
134 [x] -> Right x
135 xs -> Left $ "Ambiguous parse for `" ++ str ++ "': " ++ show xs
136 cases [] = []
137 cases (c:cs) = [(c':cs') | c' <- [toLower c, toUpper c], cs' <- cases cs]
138
139rTime :: ReadM UTCTime
140rTime = eitherReader rTime'
141 where
142 rTime' str = maybe (Left $ "Could not parse `" ++ str ++ "' as a specification of time -- try the output of `date -u +'%Y-%m-%d %H:%M:%S' \"" ++ str ++ "\"`") Right
143 . foldr (<|>) Nothing
144 $ map (flip (parseTimeM True defaultTimeLocale) str) ( "%c" : "%s" : perms' [ [time, date, timezone] | time <- ["%T", "%X", "%I:%M:%S", "%r", "%X%Q", "%I:%M:%S%Q %p"], date <- ["%x", "%F"], timezone <- ["%z", "%Z"]] )
145 perms' :: [[String]] -> [String]
146 perms' = map unwords . concatMap subsequences . concatMap permutations
147
148pRange :: ReadM a
149 -> Mod OptionFields a -- ^ Modifiers applied to both min & max
150 -> Mod OptionFields a -- ^ Modifiers for minimum
151 -> Mod OptionFields a -- ^ Modifiers for maximum
152 -> Parser (Maybe (Range a))
153pRange r both min max = toRange <$> optional (option r (both <> min)) <*> optional (option r (both <> max))
154 where
155 toRange Nothing Nothing = Nothing
156 toRange (Just min) Nothing = Just $ Min min
157 toRange Nothing (Just max) = Just $ Max max
158 toRange (Just min) (Just max) = Just $ min `Through` max
159
160main :: IO () 21main :: IO ()
161main = customExecParser (prefs $ showHelpOnError) (info pTPrint $ header "tprint - A cli interface to Thermoprint.Client") >>= tprint 22main = withArgs (tprint <=< dumpOpts)
23 where
24 dumpOpts c@(TPrint{..}) = c <$ when (dumpOptions) (hPutStrLn stderr $ dumpStr c)
162 25
163tprint :: TPrint -> IO () 26tprint :: TPrint -> IO ()
164tprint = putStrLn . dumpStr -- *DEBUG* 27tprint = undefined
diff --git a/tprint/src/Options.hs b/tprint/src/Options.hs
new file mode 100644
index 0000000..96bbde6
--- /dev/null
+++ b/tprint/src/Options.hs
@@ -0,0 +1,115 @@
1{-# LANGUAGE StandaloneDeriving #-}
2{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
3
4module Options
5 ( TPrint(..)
6 , Operation(..)
7 , Input, Output
8 , Format(..), Source(..), Sink(..)
9 , withArgs
10 , module Options.Utils
11 ) where
12
13import Data.Time
14
15import GHC.Generics (Generic)
16
17import Text.Show.Pretty (PrettyVal)
18
19import Thermoprint.Client
20import Options.Applicative
21
22import Options.Utils
23import Instances ()
24
25data TPrint = TPrint
26 { baseUrl :: BaseUrl
27 , dryRun :: Bool
28 , output :: Output
29 , operation :: Operation
30 , dumpOptions :: Bool
31 }
32 deriving (Show, Generic, PrettyVal)
33
34data Operation
35 = Printers
36 | Jobs
37 { printer :: Maybe PrinterId
38 , jobRange :: Maybe (Range JobId)
39 , timeRange :: Maybe (Range UTCTime)
40 }
41 | JobCreate
42 { printer :: Maybe PrinterId
43 , input :: Input
44 }
45 | Job { jobId :: JobId }
46 | JobStatus { jobId :: JobId }
47 | JobDelete { jobId :: JobId }
48 | Drafts
49 | DraftCreate
50 { draftTitle :: Maybe DraftTitle
51 , input :: Input
52 }
53 | DraftReplace
54 { draftId :: DraftId
55 , draftTitle :: Maybe DraftTitle
56 , input :: Input
57 }
58 | Draft { draftId :: DraftId }
59 | DraftDelete { draftId :: DraftId }
60 | DraftPrint
61 { draftId :: DraftId
62 , printer :: Maybe PrinterId
63 }
64 deriving (Show, Generic, PrettyVal)
65
66type Input = (Format, Source)
67type Output = (Format, Sink )
68
69data Format = Human | BBCode | Internal | JSON
70 deriving (Enum, Bounded, Show, Read, Generic, PrettyVal)
71
72data Source = Stdin | ReadFile FilePath
73 deriving (Show, Generic, PrettyVal)
74
75data Sink = Stdout | WriteFile FilePath
76 deriving (Show, Generic, PrettyVal)
77
78cmdPrinters :: ParserInfo Operation
79cmdPrinters = info cmdPrinters' $ mconcat [ header "List all available printers"
80 ]
81 where cmdPrinters' = pure Printers
82
83cmdJobs :: ParserInfo Operation
84cmdJobs = info cmdJobs' $ mconcat [ header "List printjobs"
85 ]
86 where
87 cmdJobs' = Jobs
88 <$> optional (option (PrinterId <$> auto) $ metavar "PRINTER" <> long "printer" <> short 'p' <> help "List only jobs associated with printer #PRINTER")
89 <*> pRange (JobId <$> auto) (metavar "JOB") (long "min-job" <> short 'j' <> help "List only jobs with id greater than or equal to JOB") (long "max-job" <> short 'J' <> help "List only jobs with id less than or equal to JOB")
90 <*> pRange rTime (metavar "TIME") (long "min-time" <> short 't' <> help "List only jobs created after or at TIME") (long "max-time" <> short 'T' <> help "List only jobs created before or at TIME")
91
92pOperation :: Parser Operation
93pOperation = hsubparser $ mconcat [ command "printers" cmdPrinters
94 , command "jobs" cmdJobs
95 ]
96
97pTPrint :: Parser TPrint
98pTPrint = TPrint <$> option (eitherReader parseBaseUrl) (metavar "URL" <> long "baseurl" <> short 'u' <> help "Server to interact with" <> value (BaseUrl Http "localhost" 3000) <> showDefaultWith showBaseUrl)
99 <*> switch (long "dry-run" <> short 'n' <> help "Don't send any requests that would be expected to change the servers state" <> showDefault)
100 <*> pOutput
101 <*> pOperation
102 <*> switch (long "dump-options" <> internal)
103
104pOutput :: Parser Output
105pOutput = (,) <$> pOutputFormat <*> pSink
106 where
107 pOutputFormat = option rCI $ metavar "FORMAT" <> long "output-format" <> short 'O' <> help ("Format to use for all output (possible values: " ++ show ([minBound..maxBound] :: [Format]) ++ ")") <> value Human <> showDefault
108 pSink = option rSink $ metavar "PATH" <> long "output" <> short 'o' <> help "Send output to PATH (`-' means stdout)" <> value Stdout <> showDefault
109 rSink = rSink' <$> str
110 where
111 rSink' "-" = Stdout
112 rSink' x = WriteFile x
113
114withArgs :: (TPrint -> IO a) -> IO a
115withArgs a = customExecParser (prefs $ showHelpOnError) (info pTPrint $ header "tprint - A cli interface to Thermoprint.Client") >>= a
diff --git a/tprint/src/Options/Utils.hs b/tprint/src/Options/Utils.hs
new file mode 100644
index 0000000..80b4a7e
--- /dev/null
+++ b/tprint/src/Options/Utils.hs
@@ -0,0 +1,48 @@
1module Options.Utils
2 ( rCI
3 , rTime
4 , pRange
5 ) where
6
7import Options.Applicative
8
9import Data.Char
10import Data.Maybe
11import Data.List
12import Text.Read
13
14import Data.Time
15
16import Thermoprint.Client (Range(..))
17
18rCI :: (Read a, Show a) => ReadM a
19rCI = eitherReader rRep'
20 where
21 rRep' str = case mapMaybe readMaybe $ cases str of
22 [] -> Left $ "Could not parse `" ++ str ++ "'"
23 [x] -> Right x
24 xs -> Left $ "Ambiguous parse for `" ++ str ++ "': " ++ show xs
25 cases [] = []
26 cases (c:cs) = [(c':cs') | c' <- [toLower c, toUpper c], cs' <- cases cs]
27
28rTime :: ReadM UTCTime
29rTime = eitherReader rTime'
30 where
31 rTime' str = maybe (Left $ "Could not parse `" ++ str ++ "' as a specification of time -- try the output of `date -u +'%Y-%m-%d %H:%M:%S' \"" ++ str ++ "\"`") Right
32 . foldr (<|>) Nothing
33 $ map (flip (parseTimeM True defaultTimeLocale) str) ( "%c" : "%s" : perms' [ [time, date, timezone] | time <- ["%T", "%X", "%I:%M:%S", "%r", "%X%Q", "%I:%M:%S%Q %p"], date <- ["%x", "%F"], timezone <- ["%z", "%Z"]] )
34 perms' :: [[String]] -> [String]
35 perms' = map unwords . concatMap subsequences . concatMap permutations
36
37pRange :: ReadM a
38 -> Mod OptionFields a -- ^ Modifiers applied to both min & max
39 -> Mod OptionFields a -- ^ Modifiers for minimum
40 -> Mod OptionFields a -- ^ Modifiers for maximum
41 -> Parser (Maybe (Range a))
42pRange r both min max = toRange <$> optional (option r (both <> min)) <*> optional (option r (both <> max))
43 where
44 toRange Nothing Nothing = Nothing
45 toRange (Just min) Nothing = Just $ Min min
46 toRange Nothing (Just max) = Just $ Max max
47 toRange (Just min) (Just max) = Just $ min `Through` max
48
diff --git a/tprint/tprint.cabal b/tprint/tprint.cabal
index d61ea01..aeb61c9 100644
--- a/tprint/tprint.cabal
+++ b/tprint/tprint.cabal
@@ -18,7 +18,9 @@ cabal-version: >=1.10
18 18
19executable tprint 19executable tprint
20 main-is: Main.hs 20 main-is: Main.hs
21 -- other-modules: 21 other-modules: Options
22 , Options.Utils
23 , Instances
22 -- other-extensions: 24 -- other-extensions:
23 build-depends: base >=4.8 && <4.9 25 build-depends: base >=4.8 && <4.9
24 , thermoprint-bbcode >=1.0.0 && <2 26 , thermoprint-bbcode >=1.0.0 && <2
@@ -27,7 +29,7 @@ executable tprint
27 , containers >=0.5.6 && <1 29 , containers >=0.5.6 && <1
28 , time >=1.5.0 && <2 30 , time >=1.5.0 && <2
29 , pretty-show >=1.6.9 && <2 31 , pretty-show >=1.6.9 && <2
30 , text -any 32 , text >=1.2.2 && <2
31 hs-source-dirs: src 33 hs-source-dirs: src
32 default-language: Haskell2010 34 default-language: Haskell2010
33 ghc-options: -Wall \ No newline at end of file 35 ghc-options: -Wall \ No newline at end of file