aboutsummaryrefslogtreecommitdiff
path: root/tprint/src/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'tprint/src/Main.hs')
-rw-r--r--tprint/src/Main.hs217
1 files changed, 0 insertions, 217 deletions
diff --git a/tprint/src/Main.hs b/tprint/src/Main.hs
deleted file mode 100644
index 0f88a86..0000000
--- a/tprint/src/Main.hs
+++ /dev/null
@@ -1,217 +0,0 @@
1{-# LANGUAGE RecordWildCards, RankNTypes #-}
2
3import Thermoprint
4import Thermoprint.Api
5
6import qualified BBCode (parse, make)
7
8import Options.Applicative
9
10import Data.Either
11import Data.Maybe
12import Control.Monad
13import Control.Monad.Trans.Either
14
15import System.IO
16import qualified System.IO as IO
17import System.Exit
18import System.Environment
19
20import Data.Proxy
21import Servant.API
22import Servant.Client
23
24import Data.Int (Int64)
25
26thermoprintApi :: Proxy ThermoprintApi
27thermoprintApi = Proxy
28
29data TPrint = TPrint TPrintMode TPrintOptions
30
31data TPrintOptions = TPrintOptions
32 { baseUrl :: BaseUrl
33 }
34
35data TPrintMode = Print PrintOptions
36 | PrintDraft PrintDraftOptions
37 | Query QueryOptions
38 | Add AddOptions
39 | Get GetOptions
40 | Write WriteOptions
41 | Del DelOptions
42
43data PrintOptions = PrintOptions
44 { printerId :: Integer
45 , dryRun :: Bool
46 }
47
48data PrintDraftOptions = PrintDraftOptions
49 { printOptions :: PrintOptions
50 , pDraftId :: Int64
51 , deleteAfter :: Bool
52 }
53
54data QueryOptions = QueryOptions
55
56data AddOptions = AddOptions
57 { title :: String
58 }
59
60data GetOptions = GetOptions
61 { gDraftId :: Int64
62 , getTitle :: Bool
63 }
64
65data WriteOptions = WriteOptions
66 { wDraftId :: Int64
67 , newTitle :: Maybe String
68 }
69
70data DelOptions = DelOptions
71 { dDraftId :: Int64
72 }
73
74
75main :: IO ()
76main = do
77 envUrl <- lookupEnv "TPRINT"
78 let
79 defaultUrl = fromMaybe (BaseUrl Http "localhost" 8080) (envUrl >>= either (const Nothing) Just . parseBaseUrl)
80 execParser (opts defaultUrl) >>= main'
81 where
82 opts url = info (helper <*> opts' url) (
83 fullDesc
84 <> header "tprint - A cli tool for interfacing with the REST api as provided by thermoprint-servant"
85 )
86 opts' url = TPrint
87 <$> modeSwitch
88 <*> commonOpts url
89 commonOpts url = TPrintOptions
90 <$> option baseUrlReader (
91 long "url"
92 <> short 'u'
93 <> metavar "URL"
94 <> help "The base url of the api. Also reads TPRINT from environment."
95 <> value url
96 <> showDefaultWith showBaseUrl
97 )
98 baseUrlReader = str >>= either readerError return . parseBaseUrl
99 modeSwitch = subparser $ mconcat $ map (\(n, f, h) -> command n $ info (helper <*> f) $ progDesc h)
100 [ ("print", print, "Read bbcode from stdin and send it to be printed")
101 , ("print-draft", printD, "Send a draft to be printed")
102 , ("query", query, "List drafts")
103 , ("add", add, "Read bbcode from stdin and add it as a draft")
104 , ("get", get, "Get a draft and print it as bbcode to stdout")
105 , ("write", write, "Read bbcode from stdin and overwrite an existing draft")
106 , ("del", del, "Delete a draft")
107 ]
108 draftN s = option auto (
109 long "draft"
110 <> short 'n'
111 <> metavar "INT"
112 <> help s
113 )
114 print = Print <$> print'
115 print' = PrintOptions
116 <$> option auto (
117 long "printer"
118 <> short 'p'
119 <> metavar "INT"
120 <> help "The number of the printer to use"
121 <> value 0
122 <> showDefault
123 )
124 <*> flag False True (
125 long "dry-run"
126 <> short 'd'
127 <> help "Instead of sending data to printer output the parsed stream to stderr"
128 <> showDefault
129 )
130 printD = (PrintDraft <$>) $ PrintDraftOptions
131 <$> print'
132 <*> draftN "The number of the draft to print"
133 <*> flag False True (
134 long "delete"
135 <> help "Delete the draft after printing"
136 )
137 query = (Query <$>) $ pure QueryOptions
138 add = (Add <$>) $ AddOptions
139 <$> strArgument (
140 metavar "TITLE"
141 <> help "The human readable title for the new draft"
142 )
143 get = (Get <$>) $ GetOptions
144 <$> draftN "The number of the draft to retrieve"
145 <*> flag False True (
146 long "title"
147 <> short 't'
148 <> help "Get title instead of content"
149 )
150 write = (Write <$>) $ WriteOptions
151 <$> draftN "The number of the draft to overwrite"
152 <*> optional ( strArgument (
153 metavar "TITLE"
154 <> help "The human readable title for the updated draft (defaults to retrieving the old one before overwriting)"
155 )
156 )
157 del = (Del <$>) $ DelOptions
158 <$> draftN "The number of the draft to delete"
159
160either' :: (a -> String) -> EitherT a IO b -> IO b
161either' f a = either (die . f) return =<< runEitherT a
162
163main' (TPrint mode TPrintOptions{..}) = do
164 let
165 -- print :: Integer -> Block String -> EitherT ServantError IO ()
166 -- queryDrafts :: EitherT ServantError IO [(Integer, String)]
167 -- addDraft :: (String, Block String) -> EitherT ServantError IO Int64
168 -- getDraft :: Int64 -> EitherT ServantError IO (String, Block String)
169 -- writeDraft :: Int64 -> (String, Block String) -> EitherT ServantError IO Int64
170 -- delDraft :: Int64 -> EitherT ServantError IO ()
171 (print :<|> queryDrafts :<|> addDraft :<|> getDraft :<|> writeDraft :<|> delDraft) = client thermoprintApi baseUrl
172 case mode of
173 Print PrintOptions{..} -> do
174 input <- BBCode.parse `liftM` getContents
175 input' <- either (die . ("Parse error: " ++)) return input
176 case dryRun of
177 False -> do
178 res <- runEitherT $ print printerId input'
179 case res of
180 Left err -> hPutStrLn stderr $ show err
181 Right _ -> exitSuccess
182 True -> do
183 hPutStrLn stderr $ show input'
184 PrintDraft PrintDraftOptions{..} -> do
185 let PrintOptions{..} = printOptions
186 (_, input) <- either' (\e -> "Error while retrieving draft: " ++ show e) $ getDraft pDraftId
187 case dryRun of
188 False -> do
189 res <- runEitherT $ print printerId input
190 case res of
191 Left err -> hPutStrLn stderr $ show err
192 Right _ -> when deleteAfter $ either' (\e -> "Error while deleting draft: " ++ show e) $ delDraft pDraftId
193 True -> do
194 hPutStrLn stderr $ show input
195 Query QueryOptions -> do
196 drafts <- either' (\e -> "Error while retrieving drafts: " ++ show e) queryDrafts
197 mapM_ (\(n, t) -> putStrLn $ "[" ++ show n ++ "]\n" ++ (unlines $ map (\s -> " " ++ s) $ lines t)) drafts
198 when (null drafts) $ hPutStrLn stderr "No drafts"
199 Add AddOptions{..} -> do
200 input <- BBCode.parse `liftM` getContents
201 input' <- either (die . ("Parse error: " ++)) return input
202 n <- either' (\e -> "Error while saving draft: " ++ show e) $ addDraft (title, input')
203 IO.print n
204 Get GetOptions{..} -> do
205 (title, draft) <- either' (\e -> "Error while retrieving draft: " ++ show e) $ getDraft gDraftId
206 case getTitle of
207 False -> putStr $ BBCode.make draft
208 True -> putStrLn title
209 Write WriteOptions{..} -> do
210 input <- BBCode.parse `liftM` getContents
211 input' <- either (die . ("Parse error: " ++)) return input
212 title <- case newTitle of
213 Just new -> return new
214 Nothing -> fst <$> (either' (\e -> "Error while retrieving draft: " ++ show e) $ getDraft wDraftId)
215 either' (\e -> "Error while overwriting draft: " ++ show e) $ writeDraft wDraftId (title, input')
216 Del DelOptions{..} -> either' (\e -> "Error while deleting draft: " ++ show e) $ delDraft dDraftId
217 _ -> undefined
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-02 21:50:13 +0000