Drafts

2 files changed, 110 insertions, 9 deletions

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"