From 6e2883f57decbdcc8cbfefb8cdd9b118212811d5 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Mon, 25 Jan 2016 17:50:00 +0000
Subject: cleaned up castId

---
 server/src/Thermoprint/Server/API.hs      | 22 +++++++++-------------
 server/src/Thermoprint/Server/Database.hs | 15 +++++++++++----
 2 files changed, 20 insertions(+), 17 deletions(-)

diff --git a/server/src/Thermoprint/Server/API.hs b/server/src/Thermoprint/Server/API.hs
index 9e28d58..66a594b 100644
--- a/server/src/Thermoprint/Server/API.hs
+++ b/server/src/Thermoprint/Server/API.hs
@@ -106,14 +106,10 @@ queue' = fmap force . liftIO . readTVarIO . queue
 
 extractJobs :: (PrinterId, Queue) -> Seq (API.JobId, JobStatus)
 -- ^ Get an API-compatible list of all jobs from a 'Printer' 'Queue'
-extractJobs (pId, Queue pending current history) = mconcat [ fmap (, Queued pId) pending'
-                                                           , maybe Seq.empty Seq.singleton (fmap (, Printing pId) current')
-                                                           , fmap (second $ maybe Done Failed) history'
+extractJobs (pId, Queue pending current history) = mconcat [ fmap ((, Queued pId) . castId) pending
+                                                           , maybe Seq.empty Seq.singleton $ fmap ((, Printing pId) . castId) current
+                                                           , fmap (bimap castId $ maybe Done Failed) history
                                                            ]
-  where
-    pending' = fmap (castId' . unJobKey) pending
-    current' = fmap (castId' . unJobKey) current
-    history' = fmap (first $ castId' . unJobKey) history
 
 listPrinters :: Handler (Map PrinterId PrinterStatus)
 listPrinters = fmap toStatus <$> (mapM (liftIO . readTVarIO . queue) . printers =<< ask)
@@ -122,13 +118,13 @@ listPrinters = fmap toStatus <$> (mapM (liftIO . readTVarIO . queue) . printers
     toStatus (Queue _ (Just id) _) = Busy . castId $ fromSqlKey id
 
 queueJob :: Maybe PrinterId -> Printout -> Handler API.JobId
-queueJob pId printout = lift . fmap (castId' . unJobKey) . withReaderT sqlPool . addToQueue printout . snd =<< lookupPrinter pId
+queueJob pId printout = lift . fmap castId . withReaderT sqlPool . addToQueue printout . snd =<< lookupPrinter pId
 
 printerStatus :: PrinterId -> Handler PrinterStatus
 printerStatus = fmap queueToStatus . queue' . snd <=< lookupPrinter . Just
   where
     queueToStatus (Queue _ Nothing   _) = Available
-    queueToStatus (Queue _ (Just id) _) = Busy . castId' $ unJobKey id
+    queueToStatus (Queue _ (Just id) _) = Busy $ castId id
 
 listJobs :: Maybe PrinterId -> Maybe API.JobId -> Maybe API.JobId -> Handler (Seq (API.JobId, JobStatus))
 listJobs Nothing minId maxId = fmap mconcat . mapM (\pId -> listJobs (Just pId) minId maxId) =<< asks (Map.keys . printers)
@@ -137,7 +133,7 @@ listJobs pId     minId maxId = fmap (filterJobs . extractJobs) . (\(a, b) -> (,)
     filterJobs = Seq.filter (\(id, _) -> maybe True (< id) minId && maybe True (> id) maxId)
 
 getJob :: API.JobId -> Handler Printout
-getJob jobId = fmap jobContent . maybe (left err404) return =<< runSqlPool (get . JobKey . SqlBackendKey $ castId jobId) =<< asks sqlPool
+getJob jobId = fmap jobContent . maybe (left err404) return =<< runSqlPool (get $ castId jobId) =<< asks sqlPool
 
 jobStatus :: API.JobId -> Handler JobStatus
 jobStatus jobId = maybe (left err404) return . lookup jobId . toList =<< listJobs Nothing Nothing Nothing
@@ -147,10 +143,10 @@ deleteJob jobId = do
   printerIds <- asks (Map.keys . printers)
   forM_ printerIds $ \pId -> do
     (pId', p) <- lookupPrinter $ Just pId
-    -- liftIO . atomically . modifyTVar' (queue p) $ force . removeNeedle
+    found <- liftIO . atomically $ do
+      current <- readTVar $ queue p
+      modifyTVar' (queue p) $ force . (\q@(Queue pending _ _) -> q { pending = Seq.filter (/= castId jobId) pending })
     undefined
-  where
-    needle = JobKey . SqlBackendKey $ castId jobId
 
 listDrafts :: Handler (Map API.DraftId (Maybe DraftTitle))
 listDrafts = return undefined
diff --git a/server/src/Thermoprint/Server/Database.hs b/server/src/Thermoprint/Server/Database.hs
index 1e01680..5bd4512 100644
--- a/server/src/Thermoprint/Server/Database.hs
+++ b/server/src/Thermoprint/Server/Database.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE ExistentialQuantification  #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving         #-}
 {-# LANGUAGE FlexibleInstances          #-}
 
 module Thermoprint.Server.Database
@@ -11,7 +12,6 @@ module Thermoprint.Server.Database
        , Draft(..), DraftId
        , Key(..)
        , migrateAll
-       , castId'
        ) where
 
 import Control.DeepSeq
@@ -32,8 +32,15 @@ Draft
     content Printout
 |]
 
+deriving instance Enum     (Key Job)
+deriving instance Num      (Key Job)
+deriving instance Real     (Key Job)
+deriving instance Integral (Key Job)
+
+deriving instance Enum     (Key Draft)
+deriving instance Num      (Key Draft)
+deriving instance Real     (Key Draft)
+deriving instance Integral (Key Draft)
+
 instance NFData (Key Job) where
   rnf = rnf . unSqlBackendKey . unJobKey
-
-castId' :: Enum b => BackendKey SqlBackend -> b
-castId' = castId . unSqlBackendKey
-- 
cgit v1.2.3