From f236eb926bd554cb6494a0184d1070f264c4d03a Mon Sep 17 00:00:00 2001 From: Gregor Kleen 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 +-- server/thermoprint-server.cabal | 2 + server/thermoprint-server.nix | 17 +++---- 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 -- cgit v1.2.3