From 61c983bd242ec45726ce572e85c069ca9274c71e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 1 Mar 2016 07:34:23 +0100 Subject: Cleanup --- tprint/src/Main.hs | 155 ++++------------------------------------------------- 1 file changed, 9 insertions(+), 146 deletions(-) (limited to 'tprint/src/Main.hs') 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 @@ {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} import Data.Map (Map) import qualified Data.Map as Map @@ -8,157 +6,22 @@ import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Text (Text) import qualified Data.Text as T -import Data.Time - -import Data.Foldable -import Data.Char -import Text.Read -import Data.Maybe -import Data.List -import GHC.Generics (Generic) +import Control.Monad -import Text.Show.Pretty (Value, PrettyVal(..), dumpStr) -import qualified Text.Show.Pretty as PShow (Value(..)) +import Text.Show.Pretty (dumpStr) + +import System.IO import Thermoprint.Client -import Options.Applicative +import Options import Debug.Trace -instance PrettyVal Scheme -instance PrettyVal BaseUrl -instance PrettyVal PrinterId -instance PrettyVal JobId -instance PrettyVal DraftId -instance PrettyVal a => PrettyVal (Range a) - -instance PrettyVal UTCTime where - prettyVal = PShow.String . formatTime defaultTimeLocale "%Z %F %X" - -instance PrettyVal Text where - prettyVal = prettyVal . T.unpack - -data TPrint = TPrint - { baseUrl :: BaseUrl - , dryRun :: Bool - , output :: Output - , operation :: Operation - } - deriving (Show, Generic, PrettyVal) - -data Operation - = Printers - | Jobs - { printer :: Maybe PrinterId - , jobRange :: Maybe (Range JobId) - , timeRange :: Maybe (Range UTCTime) - } - | JobCreate - { printer :: Maybe PrinterId - , input :: Input - } - | Job { jobId :: JobId } - | JobStatus { jobId :: JobId } - | JobDelete { jobId :: JobId } - | Drafts - | DraftCreate - { draftTitle :: Maybe DraftTitle - , input :: Input - } - | DraftReplace - { draftId :: DraftId - , draftTitle :: Maybe DraftTitle - , input :: Input - } - | Draft { draftId :: DraftId } - | DraftDelete { draftId :: DraftId } - | DraftPrint - { draftId :: DraftId - , printer :: Maybe PrinterId - } - deriving (Show, Generic, PrettyVal) - -type Input = (Format, Source) -type Output = (Format, Sink ) - -data Format = Human | BBCode | Internal | JSON - deriving (Enum, Bounded, Show, Read, Generic, PrettyVal) - -data Source = Stdin | ReadFile FilePath - deriving (Show, Generic, PrettyVal) - -data Sink = Stdout | WriteFile FilePath - deriving (Show, Generic, PrettyVal) - -cmdPrinters :: ParserInfo Operation -cmdPrinters = info cmdPrinters' $ mconcat [ header "List all available printers" - ] - where cmdPrinters' = pure Printers - -cmdJobs :: ParserInfo Operation -cmdJobs = info cmdJobs' $ mconcat [ header "List printjobs" - ] - where - cmdJobs' = Jobs - <$> optional (option (PrinterId <$> auto) $ metavar "PRINTER" <> long "printer" <> short 'p' <> help "List only jobs associated with printer #PRINTER") - <*> 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") - <*> 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") - -pOperation :: Parser Operation -pOperation = hsubparser $ mconcat [ command "printers" cmdPrinters - , command "jobs" cmdJobs - ] - -pTPrint :: Parser TPrint -pTPrint = TPrint <$> option (eitherReader parseBaseUrl) (metavar "URL" <> long "baseurl" <> short 'u' <> help "Server to interact with" <> value (BaseUrl Http "localhost" 3000) <> showDefaultWith showBaseUrl) - <*> switch (long "dry-run" <> short 'n' <> help "Don't send any requests that would be expected to change the servers state" <> showDefault) - <*> pOutput - <*> pOperation - -pOutput :: Parser Output -pOutput = (,) <$> pOutputFormat <*> pSink - where - 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 - pSink = option rSink $ metavar "PATH" <> long "output" <> short 'o' <> help "Send output to PATH (`-' means stdout)" <> value Stdout <> showDefault - rSink = rSink' <$> str - where - rSink' "-" = Stdout - rSink' x = WriteFile x - -ciAuto :: (Read a, Show a) => ReadM a -ciAuto = eitherReader rRep' - where - rRep' str = case mapMaybe readMaybe $ cases str of - [] -> Left $ "Could not parse `" ++ str ++ "'" - [x] -> Right x - xs -> Left $ "Ambiguous parse for `" ++ str ++ "': " ++ show xs - cases [] = [] - cases (c:cs) = [(c':cs') | c' <- [toLower c, toUpper c], cs' <- cases cs] - -rTime :: ReadM UTCTime -rTime = eitherReader rTime' - where - 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 - . foldr (<|>) Nothing - $ 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"]] ) - perms' :: [[String]] -> [String] - perms' = map unwords . concatMap subsequences . concatMap permutations - -pRange :: ReadM a - -> Mod OptionFields a -- ^ Modifiers applied to both min & max - -> Mod OptionFields a -- ^ Modifiers for minimum - -> Mod OptionFields a -- ^ Modifiers for maximum - -> Parser (Maybe (Range a)) -pRange r both min max = toRange <$> optional (option r (both <> min)) <*> optional (option r (both <> max)) - where - toRange Nothing Nothing = Nothing - toRange (Just min) Nothing = Just $ Min min - toRange Nothing (Just max) = Just $ Max max - toRange (Just min) (Just max) = Just $ min `Through` max - main :: IO () -main = customExecParser (prefs $ showHelpOnError) (info pTPrint $ header "tprint - A cli interface to Thermoprint.Client") >>= tprint +main = withArgs (tprint <=< dumpOpts) + where + dumpOpts c@(TPrint{..}) = c <$ when (dumpOptions) (hPutStrLn stderr $ dumpStr c) tprint :: TPrint -> IO () -tprint = putStrLn . dumpStr -- *DEBUG* +tprint = undefined -- cgit v1.2.3