Drafts

5 files changed, 126 insertions, 12 deletions

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"