1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
{-# 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 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 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
|]
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" }
liftIO $ withFile printerPath WriteMode doPrint
where
doPrint handle = do
hSetBuffering handle NoBuffering
LBS.hPut handle $ render' printOut
genericIndex :: Integral i => [a] -> i -> Maybe a
genericIndex (x:_) 0 = Just x
genericIndex (_:xs) n
| n > 0 = genericIndex xs (n - 1)
| 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 (
long "port"
<> short 'p'
<> metavar "PORT"
<> help "The port we'll run the server on"
<> 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"
))
thermoprintApi :: Proxy ThermoprintApi
thermoprintApi = Proxy
main :: IO ()
main = do
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{..}) = withSqlitePool (T.pack connStr) connNmbr $ main''
where
main'' cPool = do
runSqlPool (runMigration migrateAll) cPool
liftIO $ run port $ serve thermoprintApi (server args cPool)
|
