Draft CRUD

4 files changed, 53 insertions, 47 deletions

diff --git a/server/src/Thermoprint/Server/API.hs b/server/src/Thermoprint/Server/API.hs
index 3c8fefe..77f33e7 100644
--- a/server/src/Thermoprint/Server/API.hs
+++ b/server/src/Thermoprint/Server/API.hs
@@ -10,48 +10,54 @@ module Thermoprint.Server.API
        , handlerNat
        ) where
 
-import Thermoprint.API hiding (JobId(..), DraftId(..))
+import           Thermoprint.API hiding (JobId(..), DraftId(..))
 import qualified Thermoprint.API as API (JobId(..), DraftId(..))
 
-import Thermoprint.Server.Printer
-import Thermoprint.Server.Database
+import           Thermoprint.Server.Printer
+import           Thermoprint.Server.Database
 
-import Data.Set (Set)
+import           Data.Set (Set)
 import qualified Data.Set as Set
-import Data.Sequence (Seq)
+import           Data.Sequence (Seq)
 import qualified Data.Sequence as Seq
-import Data.Map (Map)
+import           Data.Map (Map)
 import qualified Data.Map as Map
 
 import qualified Data.Text as T
 
-import Servant
-import Servant.Server
-import Servant.Server.Internal.Enter
+import           Servant
+import           Servant.Server
+import           Servant.Server.Internal.Enter
 
-import Control.Monad.Logger
-import Control.Monad.Reader
-import Control.Monad.Trans.Resource
-import Control.Monad.Trans.Either
-import Control.Monad.IO.Class
+import           Control.Monad.Logger
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Control.Monad.Trans.Either
+import           Control.Monad.IO.Class
 
-import Control.Concurrent.STM
+import           Control.Concurrent.STM
 
-import Control.Monad ((<=<), liftM2)
-import Prelude hiding ((.), id, mapM)
-import Control.Category
+import           Control.Monad ((<=<), liftM2)
+import           Prelude hiding ((.), id, mapM)
+import           Control.Category
 
-import Control.DeepSeq
+import           Control.DeepSeq
 
-import Data.Foldable (toList)
-import Data.Traversable (mapM)
-import Data.Bifunctor
-import Data.Monoid
-import Data.Maybe
-import Data.Function (on)
+import           Data.Foldable (toList)
+import           Data.Traversable (mapM)
+import           Data.Bifunctor
+import           Data.Monoid
+import           Data.Maybe
+import           Data.Function (on)
 
-import Database.Persist
-import Database.Persist.Sql
+import           Database.Persist
+import           Database.Persist.Sql
+
+import           Data.Conduit (Source, sourceToList, mapOutput)
+
+import           Data.Acquire (with)
+
+import           Control.Monad.Catch (handle, catch)
 
 type ProtoHandler = ReaderT HandlerInput (LoggingT (ResourceT IO))
 type Handler      = EitherT ServantErr ProtoHandler
@@ -156,19 +162,21 @@ abortJob jobId = do
   when (not found) $ left err404
 
 listDrafts :: Handler (Map API.DraftId (Maybe DraftTitle))
-listDrafts = return undefined
+listDrafts = asks sqlPool >>= runSqlPool (selectSourceRes [] []) >>= flip with toMap
+  where
+    toMap source = fmap Map.fromList . sourceToList $ (\(Entity key (Draft title _)) -> (castId key, title)) `mapOutput` source
 
 addDraft :: Maybe DraftTitle -> Printout -> Handler API.DraftId
-addDraft = return undefined
+addDraft title content = fmap castId . runSqlPool (insert $ Draft title content) =<< asks sqlPool
 
 updateDraft :: API.DraftId -> Maybe DraftTitle -> Printout -> Handler ()
-updateDraft = return undefined
+updateDraft draftId title content = (\(KeyNotFound _) -> left $ err404) `handle` (runSqlPool (update (castId draftId) [ DraftTitle =. title, DraftContent =. content ]) =<< asks sqlPool)
 
 getDraft :: API.DraftId -> Handler (Maybe DraftTitle, Printout)
-getDraft = return undefined
+getDraft draftId = fmap (\(Draft title content) -> (title, content)) . maybe (left err404) return =<< runSqlPool (get $ castId draftId) =<< asks sqlPool
 
 deleteDraft :: API.DraftId -> Handler ()
-deleteDraft = return undefined
+deleteDraft draftId = runSqlPool (delete $ (castId draftId :: Key Draft)) =<< asks sqlPool
 
 printDraft :: API.DraftId -> Maybe PrinterId -> Handler API.JobId
-printDraft = return undefined
+printDraft draftId printerId = (\(Draft _ content) -> queueJob printerId content) =<< maybe (left err404) return =<< runSqlPool (get $ castId draftId) =<< asks sqlPool
diff --git a/server/src/Thermoprint/Server/Database.hs b/server/src/Thermoprint/Server/Database.hs
index 5bd4512..7f21bf9 100644
--- a/server/src/Thermoprint/Server/Database.hs
+++ b/server/src/Thermoprint/Server/Database.hs
@@ -7,12 +7,7 @@
 {-# LANGUAGE StandaloneDeriving         #-}
 {-# LANGUAGE FlexibleInstances          #-}
 
-module Thermoprint.Server.Database
-       ( Job(..), JobId
-       , Draft(..), DraftId
-       , Key(..)
-       , migrateAll
-       ) where
+module Thermoprint.Server.Database where
 
 import Control.DeepSeq
 
diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal
index dd495c0..181bd9a 100644
--- a/server/thermoprint-server.cabal
+++ b/server/thermoprint-server.cabal
@@ -43,6 +43,8 @@ library
                      , stm >=2.4.4 && <3
                      , deepseq >=1.4.1 && <2
                      , monad-control >=1.0.0 && <2
+                     , conduit >=1.2.6 && <2
+                     , exceptions >=0.8.0 && <1
   hs-source-dirs:      src
   default-language:    Haskell2010
 
diff --git a/server/thermoprint-server.nix b/server/thermoprint-server.nix
index 46859e2..8ac5456 100644
--- a/server/thermoprint-server.nix
+++ b/server/thermoprint-server.nix
@@ -1,7 +1,8 @@
-{ mkDerivation, base, containers, data-default-class, deepseq, dyre
-, either, monad-control, monad-logger, mtl, persistent
-, persistent-sqlite, persistent-template, resourcet, servant-server
-, stdenv, stm, text, thermoprint-spec, transformers, wai, warp
+{ mkDerivation, base, conduit, containers, data-default-class
+, deepseq, dyre, either, exceptions, monad-control, monad-logger
+, mtl, persistent, persistent-sqlite, persistent-template
+, resourcet, servant-server, stdenv, stm, text, thermoprint-spec
+, transformers, wai, warp
 }:
 mkDerivation {
   pname = "thermoprint-server";
@@ -10,10 +11,10 @@ mkDerivation {
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    base containers data-default-class deepseq dyre either
-    monad-control monad-logger mtl persistent persistent-template
-    resourcet servant-server stm text thermoprint-spec transformers wai
-    warp
+    base conduit containers data-default-class deepseq dyre either
+    exceptions monad-control monad-logger mtl persistent
+    persistent-template resourcet servant-server stm text
+    thermoprint-spec transformers wai warp
   ];
   executableHaskellDepends = [
     base monad-logger mtl persistent-sqlite resourcet