Drafts

10 files changed, 322 insertions, 73 deletions

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";