From fc83a7241e27574ef2bb81de206c59a9a854efe6 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 1 Mar 2016 06:25:23 +0100 Subject: First work on argument parsing --- tprint/src/Main.hs | 164 ++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 163 insertions(+), 1 deletion(-) (limited to 'tprint/src') diff --git a/tprint/src/Main.hs b/tprint/src/Main.hs index e9e1deb..e8d4670 100644 --- a/tprint/src/Main.hs +++ b/tprint/src/Main.hs @@ -1,2 +1,164 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} + +import Data.Map (Map) +import qualified Data.Map as Map +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 Text.Show.Pretty (Value, PrettyVal(..), dumpStr) +import qualified Text.Show.Pretty as PShow (Value(..)) + +import Thermoprint.Client +import Options.Applicative + +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 = undefined +main = customExecParser (prefs $ showHelpOnError) (info pTPrint $ header "tprint - A cli interface to Thermoprint.Client") >>= tprint + +tprint :: TPrint -> IO () +tprint = putStrLn . dumpStr -- *DEBUG* -- cgit v1.2.3