aboutsummaryrefslogtreecommitdiff
path: root/servant/src
diff options
context:
space:
mode:
authorGregor Kleen <gkleen@yggdrasil.li>2015-12-25 17:56:13 +0000
committerGregor Kleen <gkleen@yggdrasil.li>2015-12-25 17:56:13 +0000
commit9db2c42f4880362cf098358de830415c14f6878c (patch)
tree2b0b9257f01eec926152746fc2e7646764063c3a /servant/src
parent08eee2f0de77ffa631e84ccf734e8e95817b7c81 (diff)
downloadthermoprint-9db2c42f4880362cf098358de830415c14f6878c.tar
thermoprint-9db2c42f4880362cf098358de830415c14f6878c.tar.gz
thermoprint-9db2c42f4880362cf098358de830415c14f6878c.tar.bz2
thermoprint-9db2c42f4880362cf098358de830415c14f6878c.tar.xz
thermoprint-9db2c42f4880362cf098358de830415c14f6878c.zip
Cleaned tree for rewrite
Diffstat (limited to 'servant/src')
-rw-r--r--servant/src/Main.hs158
-rw-r--r--servant/src/PrintOut.hs14
2 files changed, 0 insertions, 172 deletions
diff --git a/servant/src/Main.hs b/servant/src/Main.hs
deleted file mode 100644
index 0aa9eeb..0000000
--- a/servant/src/Main.hs
+++ /dev/null
@@ -1,158 +0,0 @@
1{-# LANGUAGE RecordWildCards, OverloadedStrings #-}
2{-# LANGUAGE EmptyDataDecls #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE QuasiQuotes #-}
8{-# LANGUAGE TemplateHaskell #-}
9{-# LANGUAGE TypeFamilies #-}
10
11import Thermoprint
12import Thermoprint.Api
13import PrintOut
14
15import qualified Data.Text.Lazy as TL
16import qualified Data.ByteString.Lazy.Char8 as LBS
17import qualified Data.ByteString.Lazy.Char8 as Lazy (ByteString)
18import qualified Data.Text as T (pack)
19import Data.ByteString (ByteString)
20import qualified Data.ByteString as BS
21
22import Data.Aeson
23import Network.Wai
24import Network.Wai.Handler.Warp
25import Servant
26import GHC.Generics
27
28import Control.Monad
29import Control.Monad.Trans.Class
30import Control.Monad.IO.Class
31import Control.Monad.Trans.Either
32
33import Control.Monad.Logger
34
35import Options.Applicative
36
37import System.IO hiding (print)
38
39import Database.Persist
40import Database.Persist.Sqlite
41import Database.Persist.TH
42
43import Data.Int (Int64)
44
45import Prelude hiding (print)
46
47share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
48Draft
49 title String
50 content PrintOut
51 deriving Show
52|]
53
54
55print :: Options -> Integer -> Block String -> EitherT ServantErr IO ()
56print Options{..} printerNo printOut = do
57 printerPath <- case genericIndex printers printerNo of
58 Just path -> return path
59 Nothing -> left $ err404 { errBody = "printerId out of bounds" }
60 liftIO $ withFile printerPath WriteMode doPrint
61 where
62 doPrint handle = do
63 hSetBuffering handle NoBuffering
64 LBS.hPut handle $ render' printOut
65 genericIndex :: Integral i => [a] -> i -> Maybe a
66 genericIndex (x:_) 0 = Just x
67 genericIndex (_:xs) n
68 | n > 0 = genericIndex xs (n - 1)
69 | otherwise = Nothing
70 genericIndex _ _ = Nothing
71
72withPool = flip runSqlPool
73
74queryDrafts :: Options -> ConnectionPool -> EitherT ServantErr IO [(Int64, String)]
75queryDrafts Options{..} cPool = withPool cPool $ do
76 drafts <- selectList [] []
77 return $ map deSQLify drafts
78 where
79 deSQLify :: Entity Draft -> (Int64, String)
80 deSQLify (Entity k (Draft title _)) = (fromSqlKey k, title)
81
82getDraft :: Options -> ConnectionPool -> Int64 -> EitherT ServantErr IO (String, Block String)
83getDraft Options{..} cPool draftId = withPool cPool $ do
84 draft <- get $ toSqlKey draftId
85 case draft of
86 Nothing -> lift $ left $ err404 { errBody = "no such draftId" }
87 Just (Draft title content) -> return (title, content)
88
89writeDraft :: Options -> ConnectionPool -> Int64 -> (String, Block String) -> EitherT ServantErr IO ()
90writeDraft Options{..} cPool draftId (draftName, draft) = withPool cPool $ repsert (toSqlKey draftId) (Draft draftName draft)
91
92addDraft :: Options -> ConnectionPool -> (String, Block String) -> EitherT ServantErr IO Int64
93addDraft Options{..} cPool (draftName, draft) = withPool cPool $ (fromSqlKey <$> insert (Draft draftName draft))
94
95delDraft :: Options -> ConnectionPool -> Int64 -> EitherT ServantErr IO ()
96delDraft Options{..} cPool draftId = withPool cPool $ delete (toSqlKey draftId :: Key Draft)
97
98data Options = Options
99 { port :: Int
100 , connStr :: String
101 , connNmbr :: Int
102 , printers :: [FilePath]
103 }
104
105server :: Options -> ConnectionPool -> Server ThermoprintApi
106server opts cPool = print opts
107 :<|> queryDrafts opts cPool
108 :<|> addDraft opts cPool
109 :<|> getDraft opts cPool
110 :<|> writeDraft opts cPool
111 :<|> delDraft opts cPool
112
113options :: Parser Options
114options = Options
115 <$> option auto (
116 long "port"
117 <> short 'p'
118 <> metavar "PORT"
119 <> help "The port we'll run the server on"
120 <> value 8080
121 <> showDefault
122 )
123 <*> strOption (
124 long "database"
125 <> short 'd'
126 <> metavar "STRING"
127 <> help "The sqlite connection string to use (can inlude some options)"
128 <> value "./storage.sqlite"
129 <> showDefault
130 )
131 <*> option auto (
132 long "database-connections"
133 <> metavar "INT"
134 <> help "The number of parallel sqlite connections to maintain"
135 <> value 2
136 <> showDefault
137 )
138 <*> some (strArgument (
139 metavar "PATH [...]"
140 <> help "Path to one of the printers to use"
141 ))
142
143thermoprintApi :: Proxy ThermoprintApi
144thermoprintApi = Proxy
145
146main :: IO ()
147main = do
148 execParser opts >>= runNoLoggingT . main'
149 where
150 opts = info (helper <*> options) (
151 fullDesc
152 <> header "thermoprint-servant - A REST server for interacting with a cheap thermoprinter"
153 )
154 main' args@(Options{..}) = withSqlitePool (T.pack connStr) connNmbr $ main''
155 where
156 main'' cPool = do
157 runSqlPool (runMigration migrateAll) cPool
158 liftIO $ run port $ serve thermoprintApi (server args cPool)
diff --git a/servant/src/PrintOut.hs b/servant/src/PrintOut.hs
deleted file mode 100644
index 5f95a22..0000000
--- a/servant/src/PrintOut.hs
+++ /dev/null
@@ -1,14 +0,0 @@
1{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE TypeSynonymInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
4module PrintOut
5 ( PrintOut
6 ) where
7
8import Thermoprint
9import Thermoprint.Api
10import Database.Persist.TH
11
12type PrintOut = Block String
13
14derivePersistFieldJSON "PrintOut"
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-26 14:56:23 +0000