From b508a6bd35d28260f307acf8ffde8b7acf843a09 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sat, 23 Jan 2016 12:52:15 +0000
Subject: Db layout, persistent-inst. & printer framework

---
 server/src/Thermoprint/Server/Database.hs          |  5 +++-
 .../src/Thermoprint/Server/Database/Instances.hs   | 33 ++++++++++++++++++++++
 server/src/Thermoprint/Server/Printer.hs           | 29 +++++++++++++++++++
 server/thermoprint-server.cabal                    |  6 +++-
 server/thermoprint-server.nix                      | 14 ++++-----
 5 files changed, 78 insertions(+), 9 deletions(-)
 create mode 100644 server/src/Thermoprint/Server/Database/Instances.hs
 create mode 100644 server/src/Thermoprint/Server/Printer.hs

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
        , migrateAll
        ) where
 
-import Thermoprint.API (Printout, DraftTitle)
+import Thermoprint.API (Printout, DraftTitle, JobStatus)
 
 import Database.Persist.TH
 
+import Thermoprint.Server.Database.Instances
+
 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
 Job
     content Printout
+    status JobStatus
 Draft
     title DraftTitle Maybe
     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 @@
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TypeSynonymInstances       #-}
+{-# LANGUAGE FlexibleInstances          #-}
+
+module Thermoprint.Server.Database.Instances where
+
+import Thermoprint.API (Printout, JobStatus, PrintingError)
+
+import Database.Persist (PersistField(..))
+import Database.Persist.Sql (PersistFieldSql(..))
+import Database.Persist.TH
+
+import Control.Monad ((<=<))
+import Data.Bifunctor
+
+import qualified Data.Aeson as JSON (encode, eitherDecodeStrict')
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy as LBS (toStrict)
+import qualified Data.Text as T (pack)
+
+import Data.Proxy
+
+-- | Instead of deriving an instance using 'derivePersistField', which would use 'show' and 'read', we write our own by hand in order to use json
+instance PersistField Printout where
+  toPersistValue   = toPersistValue . LBS.toStrict . JSON.encode
+  fromPersistValue = first T.pack . JSON.eitherDecodeStrict' <=< fromPersistValue
+
+instance PersistFieldSql Printout where
+  sqlType _ = sqlType (Proxy :: Proxy ByteString)
+
+derivePersistField "PrintingError"
+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 @@
+{-# LANGUAGE RankNTypes #-}
+
+module Thermoprint.Server.Printer
+       ( Printer
+       ) where
+
+import Thermoprint.API (PrintingError(..), Printout)
+
+import Thermoprint.Server.Database
+
+import Database.Persist
+import Database.Persist.Sql
+
+import Data.Sequence (Seq, ViewL(..))
+import qualified Data.Sequence as Seq
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import Control.Monad.IO.Class (MonadIO)
+
+import Control.Concurrent.STM
+
+data Printer = Printer
+  { print :: forall m. (MonadIO m) => Printout -> m (Maybe PrintingError)
+  , queue :: TVar (Seq JobId)
+  }
+
+runPrinter :: Printer -> IO ()
+runPrinter = undefined
diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal
index 45f24d3..bd22482 100644
--- a/server/thermoprint-server.cabal
+++ b/server/thermoprint-server.cabal
@@ -20,7 +20,8 @@ library
   exposed-modules:     Thermoprint.Server
                      , Thermoprint.Server.Database
                      , Thermoprint.Server.API
-  -- other-modules:       
+                     , Thermoprint.Server.Printer
+  other-modules:       Thermoprint.Server.Database.Instances
   -- other-extensions:    
   build-depends:       base >=4.8 && <5
                      , thermoprint-spec ==3.0.*
@@ -38,6 +39,9 @@ library
                      , containers >=0.5.6 && <1
                      , either >=4.4.1 && <5
                      , text >=1.2.1 && <2
+                     , stm >=2.4.4 && <3
+                     , aeson >=0.9.0 && <1
+                     , bytestring >=0.10.6 && <1
   hs-source-dirs:      src
   default-language:    Haskell2010
 
diff --git a/server/thermoprint-server.nix b/server/thermoprint-server.nix
index c48ec7f..0f85c9d 100644
--- a/server/thermoprint-server.nix
+++ b/server/thermoprint-server.nix
@@ -1,7 +1,7 @@
-{ mkDerivation, base, containers, data-default-class, dyre, either
-, monad-logger, mtl, persistent, persistent-sqlite
-, persistent-template, resourcet, servant-server, stdenv, text
-, thermoprint-spec, transformers, wai, warp
+{ mkDerivation, aeson, base, bytestring, containers
+, data-default-class, dyre, either, monad-logger, mtl, persistent
+, persistent-sqlite, persistent-template, resourcet, servant-server
+, stdenv, stm, text, thermoprint-spec, transformers, wai, warp
 }:
 mkDerivation {
   pname = "thermoprint-server";
@@ -10,9 +10,9 @@ mkDerivation {
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    base containers data-default-class dyre either monad-logger mtl
-    persistent persistent-template resourcet servant-server text
-    thermoprint-spec transformers wai warp
+    aeson base bytestring containers data-default-class dyre either
+    monad-logger mtl persistent persistent-template resourcet
+    servant-server stm text thermoprint-spec transformers wai warp
   ];
   executableHaskellDepends = [
     base monad-logger mtl persistent-sqlite resourcet
-- 
cgit v1.2.3