From 9db2c42f4880362cf098358de830415c14f6878c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 25 Dec 2015 17:56:13 +0000 Subject: Cleaned tree for rewrite --- tprint/src/Main.hs | 217 ----------------------------------------------------- 1 file changed, 217 deletions(-) delete mode 100644 tprint/src/Main.hs (limited to 'tprint/src/Main.hs') 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 @@ -{-# LANGUAGE RecordWildCards, RankNTypes #-} - -import Thermoprint -import Thermoprint.Api - -import qualified BBCode (parse, make) - -import Options.Applicative - -import Data.Either -import Data.Maybe -import Control.Monad -import Control.Monad.Trans.Either - -import System.IO -import qualified System.IO as IO -import System.Exit -import System.Environment - -import Data.Proxy -import Servant.API -import Servant.Client - -import Data.Int (Int64) - -thermoprintApi :: Proxy ThermoprintApi -thermoprintApi = Proxy - -data TPrint = TPrint TPrintMode TPrintOptions - -data TPrintOptions = TPrintOptions - { baseUrl :: BaseUrl - } - -data TPrintMode = Print PrintOptions - | PrintDraft PrintDraftOptions - | Query QueryOptions - | Add AddOptions - | Get GetOptions - | Write WriteOptions - | Del DelOptions - -data PrintOptions = PrintOptions - { printerId :: Integer - , dryRun :: Bool - } - -data PrintDraftOptions = PrintDraftOptions - { printOptions :: PrintOptions - , pDraftId :: Int64 - , deleteAfter :: Bool - } - -data QueryOptions = QueryOptions - -data AddOptions = AddOptions - { title :: String - } - -data GetOptions = GetOptions - { gDraftId :: Int64 - , getTitle :: Bool - } - -data WriteOptions = WriteOptions - { wDraftId :: Int64 - , newTitle :: Maybe String - } - -data DelOptions = DelOptions - { dDraftId :: Int64 - } - - -main :: IO () -main = do - envUrl <- lookupEnv "TPRINT" - let - defaultUrl = fromMaybe (BaseUrl Http "localhost" 8080) (envUrl >>= either (const Nothing) Just . parseBaseUrl) - execParser (opts defaultUrl) >>= main' - where - opts url = info (helper <*> opts' url) ( - fullDesc - <> header "tprint - A cli tool for interfacing with the REST api as provided by thermoprint-servant" - ) - opts' url = TPrint - <$> modeSwitch - <*> commonOpts url - commonOpts url = TPrintOptions - <$> option baseUrlReader ( - long "url" - <> short 'u' - <> metavar "URL" - <> help "The base url of the api. Also reads TPRINT from environment." - <> value url - <> showDefaultWith showBaseUrl - ) - baseUrlReader = str >>= either readerError return . parseBaseUrl - modeSwitch = subparser $ mconcat $ map (\(n, f, h) -> command n $ info (helper <*> f) $ progDesc h) - [ ("print", print, "Read bbcode from stdin and send it to be printed") - , ("print-draft", printD, "Send a draft to be printed") - , ("query", query, "List drafts") - , ("add", add, "Read bbcode from stdin and add it as a draft") - , ("get", get, "Get a draft and print it as bbcode to stdout") - , ("write", write, "Read bbcode from stdin and overwrite an existing draft") - , ("del", del, "Delete a draft") - ] - draftN s = option auto ( - long "draft" - <> short 'n' - <> metavar "INT" - <> help s - ) - print = Print <$> print' - print' = PrintOptions - <$> option auto ( - long "printer" - <> short 'p' - <> metavar "INT" - <> help "The number of the printer to use" - <> value 0 - <> showDefault - ) - <*> flag False True ( - long "dry-run" - <> short 'd' - <> help "Instead of sending data to printer output the parsed stream to stderr" - <> showDefault - ) - printD = (PrintDraft <$>) $ PrintDraftOptions - <$> print' - <*> draftN "The number of the draft to print" - <*> flag False True ( - long "delete" - <> help "Delete the draft after printing" - ) - query = (Query <$>) $ pure QueryOptions - add = (Add <$>) $ AddOptions - <$> strArgument ( - metavar "TITLE" - <> help "The human readable title for the new draft" - ) - get = (Get <$>) $ GetOptions - <$> draftN "The number of the draft to retrieve" - <*> flag False True ( - long "title" - <> short 't' - <> help "Get title instead of content" - ) - write = (Write <$>) $ WriteOptions - <$> draftN "The number of the draft to overwrite" - <*> optional ( strArgument ( - metavar "TITLE" - <> help "The human readable title for the updated draft (defaults to retrieving the old one before overwriting)" - ) - ) - del = (Del <$>) $ DelOptions - <$> draftN "The number of the draft to delete" - -either' :: (a -> String) -> EitherT a IO b -> IO b -either' f a = either (die . f) return =<< runEitherT a - -main' (TPrint mode TPrintOptions{..}) = do - let - -- print :: Integer -> Block String -> EitherT ServantError IO () - -- queryDrafts :: EitherT ServantError IO [(Integer, String)] - -- addDraft :: (String, Block String) -> EitherT ServantError IO Int64 - -- getDraft :: Int64 -> EitherT ServantError IO (String, Block String) - -- writeDraft :: Int64 -> (String, Block String) -> EitherT ServantError IO Int64 - -- delDraft :: Int64 -> EitherT ServantError IO () - (print :<|> queryDrafts :<|> addDraft :<|> getDraft :<|> writeDraft :<|> delDraft) = client thermoprintApi baseUrl - case mode of - Print PrintOptions{..} -> do - input <- BBCode.parse `liftM` getContents - input' <- either (die . ("Parse error: " ++)) return input - case dryRun of - False -> do - res <- runEitherT $ print printerId input' - case res of - Left err -> hPutStrLn stderr $ show err - Right _ -> exitSuccess - True -> do - hPutStrLn stderr $ show input' - PrintDraft PrintDraftOptions{..} -> do - let PrintOptions{..} = printOptions - (_, input) <- either' (\e -> "Error while retrieving draft: " ++ show e) $ getDraft pDraftId - case dryRun of - False -> do - res <- runEitherT $ print printerId input - case res of - Left err -> hPutStrLn stderr $ show err - Right _ -> when deleteAfter $ either' (\e -> "Error while deleting draft: " ++ show e) $ delDraft pDraftId - True -> do - hPutStrLn stderr $ show input - Query QueryOptions -> do - drafts <- either' (\e -> "Error while retrieving drafts: " ++ show e) queryDrafts - mapM_ (\(n, t) -> putStrLn $ "[" ++ show n ++ "]\n" ++ (unlines $ map (\s -> " " ++ s) $ lines t)) drafts - when (null drafts) $ hPutStrLn stderr "No drafts" - Add AddOptions{..} -> do - input <- BBCode.parse `liftM` getContents - input' <- either (die . ("Parse error: " ++)) return input - n <- either' (\e -> "Error while saving draft: " ++ show e) $ addDraft (title, input') - IO.print n - Get GetOptions{..} -> do - (title, draft) <- either' (\e -> "Error while retrieving draft: " ++ show e) $ getDraft gDraftId - case getTitle of - False -> putStr $ BBCode.make draft - True -> putStrLn title - Write WriteOptions{..} -> do - input <- BBCode.parse `liftM` getContents - input' <- either (die . ("Parse error: " ++)) return input - title <- case newTitle of - Just new -> return new - Nothing -> fst <$> (either' (\e -> "Error while retrieving draft: " ++ show e) $ getDraft wDraftId) - either' (\e -> "Error while overwriting draft: " ++ show e) $ writeDraft wDraftId (title, input') - Del DelOptions{..} -> either' (\e -> "Error while deleting draft: " ++ show e) $ delDraft dDraftId - _ -> undefined -- cgit v1.2.3