From e65e1eaac335a4738abb9e8ee8da7a229f96c2c0 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 17 Oct 2015 21:23:45 +0200 Subject: Drafts --- bbcode/src/BBCode.hs | 12 +++ default.result.do | 18 ---- servant/api/Thermoprint/Api.hs | 9 +- servant/servant.cabal | 6 +- servant/servant.nix | 4 +- servant/src/Main.hs | 105 +++++++++++++++++-- servant/src/PrintOut.hs | 14 +++ tprint/src/Main.hs | 222 +++++++++++++++++++++++++++++++++-------- tprint/tprint.cabal | 1 + tprint/tprint.nix | 4 +- 10 files changed, 322 insertions(+), 73 deletions(-) delete mode 100644 default.result.do create mode 100644 servant/src/PrintOut.hs diff --git a/bbcode/src/BBCode.hs b/bbcode/src/BBCode.hs index 750fb0f..3071db6 100644 --- a/bbcode/src/BBCode.hs +++ b/bbcode/src/BBCode.hs @@ -2,6 +2,7 @@ module BBCode ( parse + , make ) where import Thermoprint @@ -42,6 +43,17 @@ testTag f k = fromMaybe False (f <$> Map.lookup (CI.mk k) knownTags) data Decorated c = Decorated c [String] deriving (Show, Eq) +make :: Block String -> String +make (Over blocks) = concat $ map make blocks +make (Center block) = "[center]" ++ make block ++ "[/center]\n" +make (Paragraph inline) = make' inline ++ "\n" + +make' :: Inline String -> String +make' (Beside inlines) = concat $ map make' inlines +make' (Underline inline) = "[u]" ++ make' inline ++ "[/u]" +make' (Cooked c) = c +make' (Raw _) = error "Cannot transform block containing raw data to bbcode" + parse :: String -> Either String (Block String) parse input = (remerge . blockify <$> (tokenize input >>= treeify)) >>= semantics diff --git a/default.result.do b/default.result.do deleted file mode 100644 index 56be121..0000000 --- a/default.result.do +++ /dev/null @@ -1,18 +0,0 @@ -case $2 in - servant) - dir=servant - name=thermoprint-servant - ;; - *) - dir=$2 - name=$2 - ;; -esac - -find $dir \( -name '*.hs' -or -name '*.cabal' -or -name '*.nix' \) -print0 | xargs --verbose --null redo-ifchange - -redo-ifchange default.nix - -nix-build -A $name -o $dir.result-link 1>&2 - -exec readlink $dir.result-link \ No newline at end of file diff --git a/servant/api/Thermoprint/Api.hs b/servant/api/Thermoprint/Api.hs index bd5744b..f3318c4 100644 --- a/servant/api/Thermoprint/Api.hs +++ b/servant/api/Thermoprint/Api.hs @@ -14,6 +14,8 @@ import GHC.Generics import Control.Monad +import Data.Int (Int64) + instance ToJSON ByteString where toJSON = toJSON . Text.pack . ByteString.unpack instance FromJSON ByteString where @@ -25,4 +27,9 @@ instance FromJSON c => FromJSON (Inline c) instance ToJSON c => ToJSON (Block c) instance FromJSON c => FromJSON (Block c) -type ThermoprintApi = "print" :> Capture "printerId" Integer :> ReqBody '[JSON] (Block String) :> Post '[JSON] () +type ThermoprintApi = "print" :> Capture "printerId" Integer :> ReqBody '[JSON] (Block String) :> Post '[JSON] () + :<|> "drafts" :> Get '[JSON] [(Int64, String)] + :<|> "drafts" :> ReqBody '[JSON] (String, Block String) :> Put '[JSON] Int64 + :<|> "drafts" :> Capture "draftId" Int64 :> Get '[JSON] (String, Block String) + :<|> "drafts" :> Capture "draftId" Int64 :> ReqBody '[JSON] (String, Block String) :> Put '[JSON] () + :<|> "drafts" :> Capture "draftId" Int64 :> Delete '[JSON] () diff --git a/servant/servant.cabal b/servant/servant.cabal index b877196..dce4490 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -48,4 +48,8 @@ executable thermoprint , bytestring >=0.10.6 && <0.11 , either >=4.4.1 && <4.5 , optparse-applicative >=0.11.0 && <0.12 - , transformers >=0.4.2 && <0.5 \ No newline at end of file + , transformers >=0.4.2 && <0.5 + , persistent >=2.2 && <3 + , persistent-template >=2.1 && <3 + , persistent-sqlite >=2.2 && <3 + , monad-logger >=0.3.13 && <1 \ No newline at end of file diff --git a/servant/servant.nix b/servant/servant.nix index a84fc77..5ea8d59 100644 --- a/servant/servant.nix +++ b/servant/servant.nix @@ -2,7 +2,8 @@ , stdenv , base , thermoprint -, aeson, wai, servant-server, warp, optparse-applicative +, aeson, wai, servant-server, warp, optparse-applicative, persistent +, persistent-template, persistent-sqlite, monad-logger }: mkDerivation { @@ -13,6 +14,7 @@ mkDerivation { isExecutable = true; executableHaskellDepends = [ base thermoprint aeson wai servant-server warp optparse-applicative + persistent persistent-template persistent-sqlite monad-logger ]; homepage = "git://git.yggdrasil.li/thermoprint"; description = "Server for interfacing to cheap thermoprinters"; diff --git a/servant/src/Main.hs b/servant/src/Main.hs index 9d88559..0aa9eeb 100644 --- a/servant/src/Main.hs +++ b/servant/src/Main.hs @@ -1,27 +1,59 @@ {-# LANGUAGE RecordWildCards, OverloadedStrings #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} import Thermoprint import Thermoprint.Api +import PrintOut +import qualified Data.Text.Lazy as TL +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.ByteString.Lazy.Char8 as Lazy (ByteString) +import qualified Data.Text as T (pack) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS + import Data.Aeson import Network.Wai import Network.Wai.Handler.Warp import Servant -import qualified Data.Text.Lazy as Text -import qualified Data.ByteString.Lazy.Char8 as ByteString -import Data.ByteString.Lazy.Char8 (ByteString) import GHC.Generics import Control.Monad +import Control.Monad.Trans.Class import Control.Monad.IO.Class import Control.Monad.Trans.Either +import Control.Monad.Logger + import Options.Applicative -import System.IO +import System.IO hiding (print) + +import Database.Persist +import Database.Persist.Sqlite +import Database.Persist.TH + +import Data.Int (Int64) + +import Prelude hiding (print) + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +Draft + title String + content PrintOut + deriving Show +|] + -server :: Options -> Integer -> Block String -> EitherT ServantErr IO () -server Options{..} printerNo printOut = do +print :: Options -> Integer -> Block String -> EitherT ServantErr IO () +print Options{..} printerNo printOut = do printerPath <- case genericIndex printers printerNo of Just path -> return path Nothing -> left $ err404 { errBody = "printerId out of bounds" } @@ -29,7 +61,7 @@ server Options{..} printerNo printOut = do where doPrint handle = do hSetBuffering handle NoBuffering - ByteString.hPut handle $ render' printOut + LBS.hPut handle $ render' printOut genericIndex :: Integral i => [a] -> i -> Maybe a genericIndex (x:_) 0 = Just x genericIndex (_:xs) n @@ -37,11 +69,47 @@ server Options{..} printerNo printOut = do | otherwise = Nothing genericIndex _ _ = Nothing +withPool = flip runSqlPool + +queryDrafts :: Options -> ConnectionPool -> EitherT ServantErr IO [(Int64, String)] +queryDrafts Options{..} cPool = withPool cPool $ do + drafts <- selectList [] [] + return $ map deSQLify drafts + where + deSQLify :: Entity Draft -> (Int64, String) + deSQLify (Entity k (Draft title _)) = (fromSqlKey k, title) + +getDraft :: Options -> ConnectionPool -> Int64 -> EitherT ServantErr IO (String, Block String) +getDraft Options{..} cPool draftId = withPool cPool $ do + draft <- get $ toSqlKey draftId + case draft of + Nothing -> lift $ left $ err404 { errBody = "no such draftId" } + Just (Draft title content) -> return (title, content) + +writeDraft :: Options -> ConnectionPool -> Int64 -> (String, Block String) -> EitherT ServantErr IO () +writeDraft Options{..} cPool draftId (draftName, draft) = withPool cPool $ repsert (toSqlKey draftId) (Draft draftName draft) + +addDraft :: Options -> ConnectionPool -> (String, Block String) -> EitherT ServantErr IO Int64 +addDraft Options{..} cPool (draftName, draft) = withPool cPool $ (fromSqlKey <$> insert (Draft draftName draft)) + +delDraft :: Options -> ConnectionPool -> Int64 -> EitherT ServantErr IO () +delDraft Options{..} cPool draftId = withPool cPool $ delete (toSqlKey draftId :: Key Draft) + data Options = Options { port :: Int + , connStr :: String + , connNmbr :: Int , printers :: [FilePath] } +server :: Options -> ConnectionPool -> Server ThermoprintApi +server opts cPool = print opts + :<|> queryDrafts opts cPool + :<|> addDraft opts cPool + :<|> getDraft opts cPool + :<|> writeDraft opts cPool + :<|> delDraft opts cPool + options :: Parser Options options = Options <$> option auto ( @@ -52,6 +120,21 @@ options = Options <> value 8080 <> showDefault ) + <*> strOption ( + long "database" + <> short 'd' + <> metavar "STRING" + <> help "The sqlite connection string to use (can inlude some options)" + <> value "./storage.sqlite" + <> showDefault + ) + <*> option auto ( + long "database-connections" + <> metavar "INT" + <> help "The number of parallel sqlite connections to maintain" + <> value 2 + <> showDefault + ) <*> some (strArgument ( metavar "PATH [...]" <> help "Path to one of the printers to use" @@ -62,10 +145,14 @@ thermoprintApi = Proxy main :: IO () main = do - execParser opts >>= main' + execParser opts >>= runNoLoggingT . main' where opts = info (helper <*> options) ( fullDesc <> header "thermoprint-servant - A REST server for interacting with a cheap thermoprinter" ) - main' args@(Options{..}) = run port $ serve thermoprintApi (server args) + main' args@(Options{..}) = withSqlitePool (T.pack connStr) connNmbr $ main'' + where + main'' cPool = do + runSqlPool (runMigration migrateAll) cPool + liftIO $ run port $ serve thermoprintApi (server args cPool) diff --git a/servant/src/PrintOut.hs b/servant/src/PrintOut.hs new file mode 100644 index 0000000..5f95a22 --- /dev/null +++ b/servant/src/PrintOut.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +module PrintOut + ( PrintOut + ) where + +import Thermoprint +import Thermoprint.Api +import Database.Persist.TH + +type PrintOut = Block String + +derivePersistFieldJSON "PrintOut" 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"; -- cgit v1.2.3