From e65e1eaac335a4738abb9e8ee8da7a229f96c2c0 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 17 Oct 2015 21:23:45 +0200 Subject: Drafts --- servant/api/Thermoprint/Api.hs | 9 +++- servant/servant.cabal | 6 ++- servant/servant.nix | 4 +- servant/src/Main.hs | 105 +++++++++++++++++++++++++++++++++++++---- servant/src/PrintOut.hs | 14 ++++++ 5 files changed, 126 insertions(+), 12 deletions(-) create mode 100644 servant/src/PrintOut.hs (limited to 'servant') 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" -- cgit v1.2.3