diff options
Diffstat (limited to 'server/src')
-rw-r--r-- | server/src/Thermoprint/Server/Database.hs | 5 | ||||
-rw-r--r-- | server/src/Thermoprint/Server/Database/Instances.hs | 33 | ||||
-rw-r--r-- | server/src/Thermoprint/Server/Printer.hs | 29 |
3 files changed, 66 insertions, 1 deletions
diff --git a/server/src/Thermoprint/Server/Database.hs b/server/src/Thermoprint/Server/Database.hs index 61179e6..65bfc37 100644 --- a/server/src/Thermoprint/Server/Database.hs +++ b/server/src/Thermoprint/Server/Database.hs | |||
@@ -11,13 +11,16 @@ module Thermoprint.Server.Database | |||
11 | , migrateAll | 11 | , migrateAll |
12 | ) where | 12 | ) where |
13 | 13 | ||
14 | import Thermoprint.API (Printout, DraftTitle) | 14 | import Thermoprint.API (Printout, DraftTitle, JobStatus) |
15 | 15 | ||
16 | import Database.Persist.TH | 16 | import Database.Persist.TH |
17 | 17 | ||
18 | import Thermoprint.Server.Database.Instances | ||
19 | |||
18 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| | 20 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| |
19 | Job | 21 | Job |
20 | content Printout | 22 | content Printout |
23 | status JobStatus | ||
21 | Draft | 24 | Draft |
22 | title DraftTitle Maybe | 25 | title DraftTitle Maybe |
23 | content Printout | 26 | content Printout |
diff --git a/server/src/Thermoprint/Server/Database/Instances.hs b/server/src/Thermoprint/Server/Database/Instances.hs new file mode 100644 index 0000000..f5c22fd --- /dev/null +++ b/server/src/Thermoprint/Server/Database/Instances.hs | |||
@@ -0,0 +1,33 @@ | |||
1 | {-# LANGUAGE TemplateHaskell #-} | ||
2 | {-# LANGUAGE TypeSynonymInstances #-} | ||
3 | {-# LANGUAGE FlexibleInstances #-} | ||
4 | |||
5 | module Thermoprint.Server.Database.Instances where | ||
6 | |||
7 | import Thermoprint.API (Printout, JobStatus, PrintingError) | ||
8 | |||
9 | import Database.Persist (PersistField(..)) | ||
10 | import Database.Persist.Sql (PersistFieldSql(..)) | ||
11 | import Database.Persist.TH | ||
12 | |||
13 | import Control.Monad ((<=<)) | ||
14 | import Data.Bifunctor | ||
15 | |||
16 | import qualified Data.Aeson as JSON (encode, eitherDecodeStrict') | ||
17 | |||
18 | import Data.ByteString (ByteString) | ||
19 | import qualified Data.ByteString.Lazy as LBS (toStrict) | ||
20 | import qualified Data.Text as T (pack) | ||
21 | |||
22 | import Data.Proxy | ||
23 | |||
24 | -- | Instead of deriving an instance using 'derivePersistField', which would use 'show' and 'read', we write our own by hand in order to use json | ||
25 | instance PersistField Printout where | ||
26 | toPersistValue = toPersistValue . LBS.toStrict . JSON.encode | ||
27 | fromPersistValue = first T.pack . JSON.eitherDecodeStrict' <=< fromPersistValue | ||
28 | |||
29 | instance PersistFieldSql Printout where | ||
30 | sqlType _ = sqlType (Proxy :: Proxy ByteString) | ||
31 | |||
32 | derivePersistField "PrintingError" | ||
33 | derivePersistField "JobStatus" | ||
diff --git a/server/src/Thermoprint/Server/Printer.hs b/server/src/Thermoprint/Server/Printer.hs new file mode 100644 index 0000000..e66afff --- /dev/null +++ b/server/src/Thermoprint/Server/Printer.hs | |||
@@ -0,0 +1,29 @@ | |||
1 | {-# LANGUAGE RankNTypes #-} | ||
2 | |||
3 | module Thermoprint.Server.Printer | ||
4 | ( Printer | ||
5 | ) where | ||
6 | |||
7 | import Thermoprint.API (PrintingError(..), Printout) | ||
8 | |||
9 | import Thermoprint.Server.Database | ||
10 | |||
11 | import Database.Persist | ||
12 | import Database.Persist.Sql | ||
13 | |||
14 | import Data.Sequence (Seq, ViewL(..)) | ||
15 | import qualified Data.Sequence as Seq | ||
16 | import Data.Map (Map) | ||
17 | import qualified Data.Map as Map | ||
18 | |||
19 | import Control.Monad.IO.Class (MonadIO) | ||
20 | |||
21 | import Control.Concurrent.STM | ||
22 | |||
23 | data Printer = Printer | ||
24 | { print :: forall m. (MonadIO m) => Printout -> m (Maybe PrintingError) | ||
25 | , queue :: TVar (Seq JobId) | ||
26 | } | ||
27 | |||
28 | runPrinter :: Printer -> IO () | ||
29 | runPrinter = undefined | ||