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/Instances.hs | 25 +++++++ tprint/src/Main.hs | 155 +++----------------------------------------- tprint/src/Options.hs | 115 ++++++++++++++++++++++++++++++++ tprint/src/Options/Utils.hs | 48 ++++++++++++++ 4 files changed, 197 insertions(+), 146 deletions(-) create mode 100644 tprint/src/Instances.hs create mode 100644 tprint/src/Options.hs create mode 100644 tprint/src/Options/Utils.hs (limited to 'tprint/src') 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 @@ +module Instances where + +import Data.Text (Text) +import qualified Data.Text as T (unpack) + +import Data.Time (UTCTime, formatTime, defaultTimeLocale) + +import Text.Show.Pretty (Value, PrettyVal(..), dumpStr) +import qualified Text.Show.Pretty as PShow (Value(..)) + +import Thermoprint.Client (Scheme(..), BaseUrl(..), PrinterId(..), JobId(..), DraftId(..), Range(..)) + +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 + 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 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 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} + +module Options + ( TPrint(..) + , Operation(..) + , Input, Output + , Format(..), Source(..), Sink(..) + , withArgs + , module Options.Utils + ) where + +import Data.Time + +import GHC.Generics (Generic) + +import Text.Show.Pretty (PrettyVal) + +import Thermoprint.Client +import Options.Applicative + +import Options.Utils +import Instances () + +data TPrint = TPrint + { baseUrl :: BaseUrl + , dryRun :: Bool + , output :: Output + , operation :: Operation + , dumpOptions :: Bool + } + 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 + <*> switch (long "dump-options" <> internal) + +pOutput :: Parser Output +pOutput = (,) <$> pOutputFormat <*> pSink + where + 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 + 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 + +withArgs :: (TPrint -> IO a) -> IO a +withArgs 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 @@ +module Options.Utils + ( rCI + , rTime + , pRange + ) where + +import Options.Applicative + +import Data.Char +import Data.Maybe +import Data.List +import Text.Read + +import Data.Time + +import Thermoprint.Client (Range(..)) + +rCI :: (Read a, Show a) => ReadM a +rCI = 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 + -- cgit v1.2.3