Drafts

3 files changed, 184 insertions, 43 deletions

diff --git a/tprint/src/Main.hs b/tprint/src/Main.hs
index 565295b..0f88a86 100644
--- a/tprint/src/Main.hs
+++ b/tprint/src/Main.hs
@@ -1,72 +1,178 @@
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RecordWildCards, RankNTypes #-}
 
 import Thermoprint
 import Thermoprint.Api
 
-import qualified BBCode (parse)
+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 Options = Options
-               { baseUrl :: BaseUrl
-               , printerId :: Integer
-               , dryRun :: Bool
-               }
-
-options :: Parser Options
-options = Options
-          <$> option baseUrlReader (
-            long "url"
-            <> short 'u'
-            <> metavar "URL"
-            <> help "The base url of the api"
-            <> value (BaseUrl Http "localhost" 8080)
-            <> showDefaultWith showBaseUrl
-            )
-          <*> 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
-            )
-  where
-    baseUrlReader = str >>= either readerError return . parseBaseUrl
+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 = execParser opts >>= main'
+main = do
+  envUrl <- lookupEnv "TPRINT"
+  let
+    defaultUrl = fromMaybe (BaseUrl Http "localhost" 8080) (envUrl >>= either (const Nothing) Just . parseBaseUrl)
+  execParser (opts defaultUrl) >>= main'
   where
-    opts = info (helper <*> options) (
+    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' Options{..} = do
-      let
-        print :: Integer -> Block String -> EitherT ServantError IO ()
-        print = client thermoprintApi baseUrl
+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 (\err -> hPutStrLn stderr ("Parse error: " ++ err) >> exitFailure) return input
+      input' <- either (die . ("Parse error: " ++)) return input
       case dryRun of
         False -> do
           res <- runEitherT $ print printerId input'
@@ -75,3 +181,37 @@ main = execParser opts >>= main'
             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
diff --git a/tprint/tprint.cabal b/tprint/tprint.cabal
index a5d2a61..54cb47d 100644
--- a/tprint/tprint.cabal
+++ b/tprint/tprint.cabal
@@ -27,5 +27,6 @@ executable tprint
                      , thermoprint-servant
                      , bbcode
                      , optparse-applicative >=0.11.0 && <1
+                     , servant >=0.4.4 && <1
                      , servant-client >=0.4.4 && <1
                      , either >=4.4.1 && <5
\ No newline at end of file
diff --git a/tprint/tprint.nix b/tprint/tprint.nix
index cce38c4..492a643 100644
--- a/tprint/tprint.nix
+++ b/tprint/tprint.nix
@@ -2,7 +2,7 @@
 , stdenv
 , base
 , thermoprint-servant, thermoprint, bbcode
-, optparse-applicative, servant-client
+, optparse-applicative, servant-client, servant
 }:
 mkDerivation {
   pname = "tprint";
@@ -12,7 +12,7 @@ mkDerivation {
   isExecutable = true;
   executableHaskellDepends = [ base
                                thermoprint thermoprint-servant bbcode
-                               optparse-applicative servant-client
+                               optparse-applicative servant-client servant
                              ];
   homepage = "git://git.yggdrasil.li/thermoprint";
   description = "A cli-tool for interfacing with thermoprint-servant";