From f236eb926bd554cb6494a0184d1070f264c4d03a Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Thu, 28 Jan 2016 12:09:41 +0000
Subject: Draft CRUD

---
 server/src/Thermoprint/Server/API.hs      | 74 +++++++++++++++++--------------
 server/src/Thermoprint/Server/Database.hs |  7 +--
 2 files changed, 42 insertions(+), 39 deletions(-)

(limited to 'server/src')

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
 
-- 
cgit v1.2.3