{-# 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